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
#'Arrange and Fill Multi-Pannel Layouts With Optional Colour Bar
#'
#'This function takes an array or list of arrays and loops over each of them
#'to plot all the sub-arrays they contain on an automatically generated
#'multi-pannel layout. A different plot function (not necessarily from
#'s2dverification) can be applied over each of the provided arrays. The input
#'dimensions of each of the functions have to be specified, either with the
#'names or the indices of the corresponding input dimensions. It is possible
#'to draw a common colour bar at any of the sides of the multi-pannel for all
#'the s2dverification plots that use a colour bar. Common plotting arguments
#'for all the arrays in 'var' can be specified via the '...' parameter, and
#'specific plotting arguments for each array can be fully adjusted via
#''special_args'. It is possible to draw titles for each of the figures,
#'layout rows, layout columns and for the whole figure. A number of parameters
#'is provided in order to adjust the position, size and colour of the
#'components. Blank cells can be forced to appear and later be filled in
#'manually with customized plots.\cr
#'This function pops up a blank new device and fills it in, so it cannot be
#'nested in complex layouts.
#'
#'@param fun Plot function (or name of the function) to be called on the
#' arrays provided in 'var'. If multiple arrays are provided in 'var', a
#' vector of as many function names (character strings!) can be provided in
#' 'fun', one for each array in 'var'.
#'@param plot_dims Numeric or character string vector with identifiers of the
#' input plot dimensions of the plot function specified in 'fun'. If
#' character labels are provided, names(dim(var)) or attr('dimensions', var)
#' will be checked to locate the dimensions. As many plots as
#' prod(dim(var)[-plot_dims]) will be generated. If multiple arrays are
#' provided in 'var', 'plot_dims' can be sent a list with a vector of plot
#' dimensions for each. If a single vector is provided, it will be used for
#' all the arrays in 'var'.
#'@param var Multi-dimensional array with at least the dimensions expected by
#' the specified plot function in 'fun'. The dimensions reqired by the
#' function must be specified in 'plot_dims'. The dimensions can be
#' disordered and will be reordered automatically. Dimensions can optionally
#' be labelled in order to refer to them with names in 'plot_dims'. All the
#' available plottable sub-arrays will be automatically plotted and arranged
#' in consecutive cells of an automatically arranged layout. A list of
#' multiple (super-)arrays can be specified. The process will be repeated for
#' each of them, by default applying the same plot function to all of them
#' or, if properly specified in 'fun', a different plot function will be
#' applied to each of them. NAs can be passed to the list: a NA will yield a
#' blank cell in the layout, which can be populated after
#' (see .SwitchToFigure).
#'@param \dots Parameters to be sent to the plotting function 'fun'. If
#' multiple arrays are provided in 'var' and multiple functions are provided
#' in 'fun', the parameters provided through \dots will be sent to all the
#' plot functions, as common parameters. To specify concrete arguments for
#' each of the plot functions see parameter 'special_args'.
#'@param special_args List of sub-lists, each sub-list having specific extra
#' arguments for each of the plot functions provided in 'fun'. If you want to
#' fix a different value for each plot in the layout you can do so by
#' a) splitting your array into a list of sub-arrays (each with the data for
#' one plot) and providing it as parameter 'var',
#' b) providing a list of named sub-lists in 'special_args', where the names
#' of each sub-list match the names of the parameters to be adjusted, and
#' each value in a sub-list contains the value of the corresponding parameter.
#'@param nrow Numeric value to force the number of rows in the automatically
#' generated layout. If higher than the required, this will yield blank cells
#' in the layout (which can then be populated). If lower than the required
#' the function will stop. By default it is configured to arrange the layout
#' in a shape as square as possible. Blank cells can be manually populated
#' after with customized plots (see SwitchTofigure).
#'@param ncol Numeric value to force the number of columns in the
#' automatically generated layout. If higher than the required, this will
#' yield blank cells in the layout (which can then be populated). If lower
#' than the required the function will stop. By default it is configured to
#' arrange the layout in a shape as square as possible. Blank cells can be
#' manually populated after with customized plots (see SwitchTofigure).
#'@param toptitle Topt title for the multi-pannel. Blank by default.
#'@param row_titles Character string vector with titles for each of the rows
#' in the layout. Blank by default.
#'@param col_titles Character string vector with titles for each of the
#' columns in the layout. Blank by default.
#'@param bar_scale Scale factor for the common colour bar. Takes 1 by default.
#'@param title_scale Scale factor for the multi-pannel title. Takes 1 by
#' default.
#'@param title_margin_scale Scale factor for the margins surrounding the top
#' title. Takes 1 by default.
#'@param title_left_shift_scale When plotting row titles, a shift is added
#' to the horizontal positioning of the top title in order to center it to
#' the region of the figures (without taking row titles into account). This
#' shift can be reduced. A value of 0 will remove the shift completely,
#' centering the title to the total width of the device. This parameter will
#' be disregarded if no 'row_titles' are provided.
#'@param subtitle_scale Scale factor for the row titles and column titles
#' (specified in 'row_titles' and 'col_titles'). Takes 1 by default.
#'@param subtitle_margin_scale Scale factor for the margins surrounding the
#' subtitles. Takes 1 by default.
#'@param units Title at the top of the colour bar, most commonly the units of
#' the variable provided in parameter 'var'.
#'@param brks,cols,bar_limits,triangle_ends Usually only providing 'brks' is
#' enough to generate the desired colour bar. These parameters allow to
#' define n breaks that define n - 1 intervals to classify each of the values
#' in 'var'. The corresponding grid cell of a given value in 'var' will be
#' coloured in function of the interval it belongs to. These parameters are
#' sent to \code{ColorBar()} to generate the breaks and colours. Additional
#' colours for values beyond the limits of the colour bar are also generated
#' and applied to the plot if 'bar_limits' or 'brks' and 'triangle_ends' are
#' properly provided to do so. See ?ColorBar for a full explanation.
#'@param col_inf,col_sup Colour identifiers to colour the values in 'var' that
#' go beyond the extremes of the colour bar and to colour NA values,
#' respectively. 'colNA' takes 'white' by default. 'col_inf' and 'col_sup'
#' will take the value of 'colNA' if not specified. See ?ColorBar for a full
#' explanation on 'col_inf' and 'col_sup'.
#'@param color_fun,subsampleg,bar_extra_labels,draw_bar_ticks,draw_separators,triangle_ends_scale,bar_label_digits,bar_label_scale,units_scale,bar_tick_scale,bar_extra_margin Set of parameters to control the visual aspect of the drawn colour bar. See ?ColorBar for a full explanation.
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
#'@param drawleg Where to draw the common colour bar. Can take values TRUE,
#' FALSE or:\cr
#' 'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr
#' 'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr
#' 'right', 'r', 'R', 'east', 'e', 'E'\cr
#' 'left', 'l', 'L', 'west', 'w', 'W'
#'@param titles Character string vector with titles for each of the figures in
#' the multi-pannel, from top-left to bottom-right. Blank by default.
#'@param bar_left_shift_scale When plotting row titles, a shift is added to
#' the horizontal positioning of the colour bar in order to center it to the
#' region of the figures (without taking row titles into account). This shift
#' can be reduced. A value of 0 will remove the shift completely, centering
#' the colour bar to the total width of the device. This parameter will be
#' disregarded if no 'row_titles' are provided.
#'@param extra_margin Extra margins to be added around the layout, in the
#' format c(y1, x1, y2, x2). The units are margin lines. Takes rep(0, 4)
#' by default.
#'@param fileout File where to save the plot. If not specified (default) a
#' graphics device will pop up. Extensions allowed: eps/ps, jpeg, png, pdf,
#' bmp and tiff.
#'@param width Width in inches of the multi-pannel. 7 by default, or 11 if
#' 'fielout' has been specified.
#'@param height Height in inches of the multi-pannel. 7 by default, or 11 if
#' 'fileout' has been specified.
#'@param size_units Units of the size of the device (file or window) to plot
#' in. Inches ('in') by default. See ?Devices and the creator function of
#' the corresponding device.
#'@param res Resolution of the device (file or window) to plot in. See
#' ?Devices and the creator function of the corresponding device.
#'@param close_device Whether to close the graphics device after plotting
#' the layout and a 'fileout' has been specified. This is useful to avoid
#' closing the device when saving the layout into a file and willing to add
#' extra elements or figures. Takes TRUE by default. Disregarded if no
#' 'fileout' has been specified.
#'
#'@return
#' Breaks used for colouring the map (and legend if drawleg = TRUE).
#' Colours used for colouring the map (and legend if drawleg = TRUE).
#' Always of length length(brks) - 1.
#' Colour used to draw the lower triangle end in the colour bar
#' (NULL if not drawn at all).
#' Colour used to draw the upper triangle end in the colour bar
#' (NULL if not drawn at all).
#' Underlying matrix of the layout. Useful to later set any of the layout
#' cells as current figure to add plot elements. See .SwitchToFigure.
#'}
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
#'@keywords dynamic
#'@author History:\cr
#' 0.1 - 2016-08 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Original code
#'@examples
#'# See examples on Load() to understand the first lines in this example
#' \dontrun{
#'data_path <- system.file('sample_data', package = 's2dverification')
#'expA <- list(name = 'experiment', path = file.path(data_path,
#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly',
#' '$VAR_NAME$_$START_DATE$.nc'))
#'obsX <- list(name = 'observation', path = file.path(data_path,
#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$',
#' '$VAR_NAME$_$YEAR$$MONTH$.nc'))
#'
#'# Now we are ready to use Load().
#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101')
#'sampleData <- Load('tos', list(expA), list(obsX), startDates,
#' leadtimemin = 1, leadtimemax = 4, output = 'lonlat',
#' latmin = 27, latmax = 48, lonmin = -12, lonmax = 40)
#' }
#' \dontshow{
#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101')
#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'),
#' c('observation'), startDates,
#' leadtimemin = 1,
#' leadtimemax = 4,
#' output = 'lonlat',
#' latmin = 27, latmax = 48,
#' lonmin = -12, lonmax = 40)
#' }
#'PlotLayout(PlotEquiMap, c('lat', 'lon'), sampleData$mod[1, , 1, 1, , ],
#' sampleData$lon, sampleData$lat,
#' toptitle = 'Predicted tos for Nov 1960 from 1st Nov',
#' titles = paste('Member', 1:15))
#'
#'@importFrom grDevices dev.cur dev.new dev.off
PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL,
nrow = NULL, ncol = NULL, toptitle = NULL,
row_titles = NULL, col_titles = NULL, bar_scale = 1,
title_scale = 1, title_margin_scale = 1,
title_left_shift_scale = 1,
subtitle_scale = 1, subtitle_margin_scale = 1,
brks = NULL, cols = NULL, drawleg = 'S', titles = NULL,
subsampleg = NULL, bar_limits = NULL,
triangle_ends = NULL, col_inf = NULL, col_sup = NULL,
color_fun = clim.colors,
triangle_ends_scale = 1, bar_extra_labels = NULL,
units = NULL, units_scale = 1, bar_label_scale = 1,
bar_tick_scale = 1, bar_extra_margin = rep(0, 4),
bar_left_shift_scale = 1, bar_label_digits = 4,
extra_margin = rep(0, 4),
fileout = NULL, width = NULL, height = NULL,
# If there is any filenames to store the graphics, process them
# to select the right device
if (!is.null(fileout)) {
deviceInfo <- .SelectDevice(fileout = fileout, width = width, height = height, units = size_units, res = res)
saveToFile <- deviceInfo$fun
fileout <- deviceInfo$files
}
is_single_na <- function(x) ifelse(length(x) > 1, FALSE, is.na(x))
if (is.array(var) || (is_single_na(var))) {
var <- list(var)
} else if (is.list(var)) {
if (!all(sapply(var, is.array) | sapply(var, is_single_na))) {
stop("Parameter 'var' must be an array or a list of arrays (or NA values).")
}
} else {
stop("Parameter 'var' must be an array or a list of arrays.")
}
if (length(fun) == 1) {
if (is.function(fun)) {
fun <- as.character(substitute(fun))
}
if (is.character(fun)) {
fun <- rep(fun, length(var))
}
if (!is.character(fun) || (length(fun) != length(var))) {
stop("Parameter 'fun' must be a single function or a vector of function names, one for each array provided in parameter 'var'.")
}
# Check special_args
if (!is.null(special_args)) {
if (!is.list(special_args) || any(!sapply(special_args, is.list))) {
stop("Parameter 'special_args' must be a list of lists.")
} else if (length(special_args) != length(var)) {
stop("Parameter 'special_args' must contain a list of special arguments for each array provided in 'var'.")
}
}
# Check plot_dims
if (is.character(plot_dims) || is.numeric(plot_dims)) {
plot_dims <- replicate(length(var), plot_dims, simplify = FALSE)
}
if (!is.list(plot_dims) || !all(sapply(plot_dims, is.character) | sapply(plot_dims, is.numeric)) ||
(length(plot_dims) != length(var))) {
stop("Parameter 'plot_dims' must contain a single numeric or character vector with dimension identifiers or a vector for each array provided in parameter 'var'.")
if (!is.null(nrow)) {
if (!is.numeric(nrow)) {
stop("Parameter 'nrow' must be numeric or NULL.")
}
nrow <- round(nrow)
}
if (!is.null(ncol)) {
if (!is.numeric(ncol)) {
stop("Parameter 'ncol' must be numeric or NULL.")
}
ncol <- round(ncol)
}
# Check toptitle
if (is.null(toptitle) || is.na(toptitle)) {
toptitle <- ''
}
if (!is.character(toptitle)) {
stop("Parameter 'toptitle' must be a character string.")
}
# Check row_titles
if (!is.null(row_titles)) {
if (!is.character(row_titles)) {
stop("Parameter 'row_titles' must be a vector of character strings.")
}
}
# Check col_titles
if (!is.null(row_titles)) {
if (!is.character(row_titles)) {
stop("Parameter 'row_titles' must be a vector of character strings.")
}
}
if (is.character(drawleg)) {
if (drawleg %in% c('up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N')) {
drawleg <- 'N'
} else if (drawleg %in% c('down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S')) {
drawleg <- 'S'
} else if (drawleg %in% c('right', 'r', 'R', 'east', 'e', 'E')) {
drawleg <- 'E'
} else if (drawleg %in% c('left', 'l', 'L', 'west', 'w', 'W')) {
drawleg <- 'W'
} else {
stop("Parameter 'drawleg' must be either TRUE, FALSE or a valid identifier of a position (see ?PlotMultiMap).")
}
} else if (!is.logical(drawleg)) {
stop("Parameter 'drawleg' must be either TRUE, FALSE or a valid identifier of a position (see ?PlotMultiMap).")
if (drawleg != FALSE && all(sapply(var, is_single_na)) &&
(is.null(brks) || length(brks) < 2)) {
stop("Either data arrays in 'var' or breaks in 'brks' must be provided if 'drawleg' is requested.")
}
# Check the rest of parameters (unless the user simply wants to build an empty layout)
var_limits <- NULL
if (!all(sapply(var, is_single_na))) {
var_limits <- c(min(unlist(var), na.rm = TRUE), max(unlist(var), na.rm = TRUE))
if ((any(is.infinite(var_limits)) || var_limits[1] == var_limits[2])) {
stop("Arrays in parameter 'var' must contain at least 2 different values.")
colorbar <- ColorBar(brks, cols, FALSE, subsampleg, bar_limits,
var_limits, triangle_ends, col_inf, col_sup, color_fun,
plot = FALSE, draw_bar_ticks,
draw_separators, triangle_ends_scale, bar_extra_labels,
units, units_scale, bar_label_scale, bar_tick_scale,
bar_extra_margin, bar_label_digits)
# Check bar_scale
if (!is.numeric(bar_scale)) {
stop("Parameter 'bar_scale' must be numeric.")
# Check bar_left_shift_scale
if (!is.numeric(bar_left_shift_scale)) {
stop("Parameter 'bar_left_shift_scale' must be numeric.")
}
# Check title_scale
if (!is.numeric(title_scale)) {
stop("Parameter 'title_scale' must be numeric.")
}
# Check title_margin_scale
if (!is.numeric(title_margin_scale)) {
stop("Parameter 'title_margin_scale' must be numeric.")
}
# Check title_left_shift_scale
if (!is.numeric(title_left_shift_scale)) {
stop("Parameter 'title_left_shift_scale' must be numeric.")
}
# Check subtitle_scale
if (!is.numeric(subtitle_scale)) {
stop("Parameter 'subtite_scale' must be numeric.")
}
# Check subtitle_margin_scale
if (!is.numeric(subtitle_margin_scale)) {
stop("Parameter 'subtite_margin_scale' must be numeric.")
}
# Check titles
if (!all(sapply(titles, is.character))) {
stop("Parameter 'titles' must be a vector of character strings.")
}
# Check extra_margin
if (!is.numeric(extra_margin) || length(extra_margin) != 4) {
stop("Parameter 'extra_margin' must be a numeric vector with 4 elements.")
}
# Check width
if (is.null(width)) {
if (is.null(fileout)) {
width <- 7
} else {
width <- 11
}
}
if (!is.numeric(width)) {
stop("Parameter 'width' must be numeric.")
}
# Check height
if (is.null(height)) {
if (is.null(fileout)) {
height <- 7
} else {
height <- 8
}
}
if (!is.numeric(height)) {
stop("Parameter 'height' must be numeric.")
}
# Check close_device
if (!is.logical(close_device)) {
stop("Parameter 'close_device' must be logical.")
}
# Count the total number of maps and reorder each array of maps to have the lat and lon dimensions at the end.
n_plots <- 0
plot_array_i <- 1
for (plot_array in var) {
if (is_single_na(plot_array)) {
n_plots <- n_plots + 1
dim_ids <- plot_dims[[plot_array_i]]
if (is.character(dim_ids)) {
dimnames <- NULL
if (!is.null(names(dim(plot_array)))) {
dimnames <- names(dim(plot_array))
} else if (!is.null(attr(plot_array, 'dimensions'))) {
dimnames <- attr(plot_array, 'dimensions')
if (!is.null(dimnames)) {
if (any(!sapply(dim_ids, `%in%`, dimnames))) {
stop("All arrays provided in parameter 'var' must have all the dimensions in 'plot_dims'.")
}
dim_ids <- sapply(dim_ids, function(x) which(dimnames == x)[1])
var[[plot_array_i]] <- .aperm2(var[[plot_array_i]], c((1:length(dim(plot_array)))[-dim_ids], dim_ids))
} else {
.warning(paste0("Assuming the ", plot_array_i, "th array provided in 'var' has 'plot_dims' as last dimensions (right-most)."))
dims <- tail(c(rep(1, length(dim_ids)), dim(plot_array)), length(dim_ids))
dim_ids <- tail(1:length(dim(plot_array)), length(dim_ids))
if (length(dim(var[[plot_array_i]])) < length(dims)) {
dim(var[[plot_array_i]]) <- dims
}
} else if (any(dim_ids > length(dim(plot_array)))) {
stop("Parameter 'plot_dims' contains dimension identifiers out of range.")
n_plots <- n_plots + prod(dim(plot_array)[-dim_ids])
#n_plots <- n_plots + prod(head(c(rep(1, length(dim_ids)), dim(plot_array)), length(dim(plot_array))))
if (length(dim(var[[plot_array_i]])) == length(dim_ids)) {
dim(var[[plot_array_i]]) <- c(1, dim(var[[plot_array_i]]))
plot_dims[[plot_array_i]] <- dim_ids
plot_array_i <- plot_array_i + 1
}
if (is.null(nrow) && is.null(ncol)) {
ncol <- ceiling(sqrt(n_plots))
nrow <- ceiling(n_plots/ncol)
} else if (is.null(ncol)) {
ncol <- ceiling(n_plots/nrow)
} else if (is.null(nrow)) {
nrow <- ceiling(n_plots/ncol)
} else if (nrow * ncol < n_plots) {
stop("There are more arrays to plot in 'var' than cells defined by 'nrow' x 'ncol'.")
}
if (is.logical(drawleg) && drawleg) {
if (nrow > ncol) {
drawleg <- 'S'
} else {
drawleg <- 'E'
}
}
# Open connection to graphical device
if (!is.null(fileout)) {
} else if (names(dev.cur()) == 'null device') {
dev.new(units = size_units, res = res, width = width, height = height)
} else if (prod(par('mfrow')) > 1) {
dev.new(units = units, res = res, width = width, height = height)
# Take size of device and set up layout:
# ---------------------------------------------
# |0000000000000000000000000000000000000000000|
# |0000000000000000 TOP TITLE 0000000000000000|
# |0000000000000000000000000000000000000000000|
# |-------------------------------------------|
# |00000|0000000000000000000000000000000000000|
# |00000|000000000000 ROW TITLES 0000000000000|
# |00000|0000000000000000000000000000000000000|
# |00000|-------------------------------------|
# |0 0|222222222222222222|333333333333333333|
# |0 C 0|222222222222222222|333333333333333333|
# |0 O 0|222222222222222222|333333333333333333|
# |0 L 0|2222 FIGURE 1 2222|3333 FIGURE 2 3333|
# |0 0|222222222222222222|333333333333333333|
# |0 T 0|222222222222222222|333333333333333333|
# |0 I 0|222222222222222222|333333333333333333|
# |0 T 0|-------------------------------------|
# |0 L 0|444444444444444444|555555555555555555|
# |0 S 0|444444444444444444|555555555555555555|
# |0 0|444444444444444444|555555555555555555|
# |00000|4444 FIGURE 3 4444|5555 FIGURE 4 5555|
# |00000|444444444444444444|555555555555555555|
# |00000|444444444444444444|555555555555555555|
# |00000|444444444444444444|555555555555555555|
# |-------------------------------------------|
# |1111111111111111111111111111111111111111111|
# |1111111111111111 COLOR BAR 1111111111111111|
# |1111111111111111111111111111111111111111111|
# ---------------------------------------------
device_size <- par('din')
device_size[1] <- device_size[1] - sum(extra_margin[c(2, 4)])
device_size[2] <- device_size[2] - sum(extra_margin[c(1, 3)])
cs <- char_size <- par('csi')
title_cex <- 2.5 * title_scale
title_margin <- 0.5 * title_cex * title_margin_scale
subtitle_cex <- 1.5 * subtitle_scale
subtitle_margin <- 0.5 * sqrt(nrow * ncol) * subtitle_cex * subtitle_margin_scale
mat_layout <- 1:(nrow * ncol) + ifelse(drawleg != FALSE, 1, 0)
mat_layout <- matrix(mat_layout, nrow, ncol, byrow = TRUE)
fsu <- figure_size_units <- 10 # unitless
widths <- rep(fsu, ncol)
heights <- rep(fsu, nrow)
n_figures <- nrow * ncol
if (length(row_titles) > 0) {
mat_layout <- cbind(rep(0, dim(mat_layout)[1]), mat_layout)
widths <- c(((subtitle_cex + subtitle_margin / 2) * cs / device_size[1]) * ncol * fsu, widths)
}
if (length(col_titles) > 0) {
mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout)
heights <- c(((subtitle_cex + subtitle_margin) * cs / device_size[2]) * nrow * fsu, heights)
}
if (drawleg != FALSE) {
if (drawleg == 'N') {
mat_layout <- rbind(rep(1, dim(mat_layout)[2]), mat_layout)
heights <- c(round(bar_scale * 2 * nrow), heights)
} else if (drawleg == 'S') {
mat_layout <- rbind(mat_layout, rep(1, dim(mat_layout)[2]))
heights <- c(heights, round(bar_scale * 2 * nrow))
} else if (drawleg == 'W') {
mat_layout <- cbind(rep(1, dim(mat_layout)[1]), mat_layout)
widths <- c(round(bar_scale * 3 * ncol), widths)
} else if (drawleg == 'E') {
mat_layout <- cbind(mat_layout, rep(1, dim(mat_layout)[1]))
widths <- c(widths, round(bar_scale * 3 * ncol))
}
n_figures <- n_figures + 1
}
if (toptitle != '') {
mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout)
heights <- c(((title_cex + title_margin) * cs / device_size[2]) * nrow * fsu, heights)
layout(mat_layout, widths, heights)
# Draw the color bar
if (drawleg != FALSE) {
if (length(row_titles) > 0) {
bar_extra_margin[2] <- bar_extra_margin[2] + (subtitle_cex + subtitle_margin / 2) *
bar_left_shift_scale
}
ColorBar(colorbar$brks, colorbar$cols, vertical, subsampleg,
bar_limits, var_limits,
triangle_ends = triangle_ends, col_inf = colorbar$col_inf,
col_sup = colorbar$col_sup, color_fun, plot = TRUE, draw_bar_ticks,
draw_separators, triangle_ends_scale, bar_extra_labels,
units, units_scale, bar_label_scale, bar_tick_scale,
bar_extra_margin, bar_label_digits)
}
# Draw titles
if (toptitle != '' || length(col_titles) > 0 || length(row_titles) > 0) {
plot(0, type = 'n', ann = FALSE, axes = FALSE, xaxs = 'i', yaxs = 'i',
xlim = c(0, 1), ylim = c(0, 1))
width_lines <- par('fin')[1] / par('csi')
plot_lines <- par('pin')[1] / par('csi')
plot_range <- par('xaxp')[2] - par('xaxp')[1]
if (toptitle != '') {
title_x_center <- par('xaxp')[1] - par('mar')[2] * size_units_per_line +
ncol * width_lines * size_units_per_line / 2
if (length(row_titles) > 0) {
title_x_center <- title_x_center - (1 - title_left_shift_scale) *
(subtitle_cex + subtitle_margin) / 2 * size_units_per_line
}
title_y_center <- par('mar')[3] + (title_margin + title_cex) / 2
if (length(col_titles > 0)) {
title_y_center <- title_y_center + (subtitle_margin + subtitle_cex)
mtext(toptitle, cex = title_cex, line = title_y_center, at = title_x_center,
padj = 0.5)
}
if (length(col_titles) > 0) {
t_x_center <- par('xaxp')[1] - par('mar')[2] * size_units_per_line
for (t in 1:ncol) {
mtext(col_titles[t], cex = subtitle_cex,
line = par('mar')[3] + (subtitle_margin + subtitle_cex) / 2,
at = t_x_center + (t - 0.5) * width_lines * size_units_per_line,
}
}
height_lines <- par('fin')[2] / par('csi')
plot_lines <- par('pin')[2] / par('csi')
plot_range <- par('yaxp')[2] - par('yaxp')[1]
if (length(row_titles) > 0) {
t_y_center <- par('yaxp')[1] - par('mar')[1] * size_units_per_line
for (t in 1:nrow) {
mtext(row_titles[t], cex = subtitle_cex,
line = par('mar')[2] + (subtitle_margin + subtitle_cex) / 2,
at = t_y_center - (t - 1.5) * height_lines * size_units_per_line,
array_number <- 1
plot_number <- 1
# For each array provided in var
if (is_single_na(x)) {
if (!all(sapply(var[array_number:length(var)], is_single_na))) {
plot.new()
plot_number <<- plot_number + 1
if (is.character(plot_dims[[array_number]])) {
plot_dim_indices <- which(names(dim(x)) %in% plot_dims[[array_number]])
} else {
plot_dim_indices <- plot_dims[[array_number]]
}
# For each of the arrays provided in that array
apply(x, (1:length(dim(x)))[-plot_dim_indices],
fun_args <- c(list(y, toptitle = titles[plot_number]), list(...),
special_args[[array_number]])
funct <- fun[[array_number]]
if (fun[[array_number]] %in% c('PlotEquiMap', 'PlotStereoMap', 'PlotSection')) {
fun_args <- c(fun_args, list(brks = colorbar$brks, cols = colorbar$cols,
col_inf = colorbar$col_inf,
col_sup = colorbar$col_sup,
drawleg = FALSE))
}
do.call(fun[[array_number]], fun_args)
plot_number <<- plot_number + 1
array_number <<- array_number + 1
# If the graphic was saved to file, close the connection with the device
if (!is.null(fileout) && close_device) dev.off()
invisible(list(brks = colorbar$brks, cols = colorbar$cols,
col_inf = colorbar$col_inf, col_sup = colorbar$col_sup,
layout_matrix = mat_layout))