Newer
Older
#'Maps A Two-Dimensional Variable On A Cylindrical Equidistant Projection
#'
#'Map longitude-latitude array (on a regular rectangular or gaussian grid)
#'on a cylindrical equidistant latitude and longitude projection with coloured
#'grid cells. Only the region for which data has been provided is displayed.
#'A colour bar (legend) can be plotted and adjusted. It is possible to draw
#'superimposed arrows, dots, symbols, contour lines and boxes. A number of
#'options is provided to adjust the position, size and colour of the
#'components. Some parameters are provided to add and adjust the masks that
#'include continents, oceans, and lakes. This plot function is compatible with
#'figure layouts if colour bar is disabled.
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
#'
#'@param var Array with the values at each cell of a grid on a regular
#' rectangular or gaussian grid. The array is expected to have two
#' dimensions: c(latitude, longitude). Longitudes can be in ascending or
#' descending order and latitudes in any order. It can contain NA values
#' (coloured with 'colNA'). Arrays with dimensions c(longitude, latitude)
#' will also be accepted but 'lon' and 'lat' will be used to disambiguate so
#' this alternative is not appropriate for square arrays.
#'@param lon Numeric vector of longitude locations of the cell centers of the
#' grid of 'var', in ascending or descending order (same as 'var'). Expected
#' to be regularly spaced, within either of the ranges [-180, 180] or
#' [0, 360]. Data for two adjacent regions split by the limits of the
#' longitude range can also be provided, e.g. \code{lon = c(0:50, 300:360)}
#' ('var' must be provided consitently).
#'@param lat Numeric vector of latitude locations of the cell centers of the
#' grid of 'var', in any order (same as 'var'). Expected to be from a regular
#' rectangular or gaussian grid, within the range [-90, 90].
#'@param varu Array of the zonal component of wind/current/other field with
#' the same dimensions as 'var'.
#'@param varv Array of the meridional component of wind/current/other field
#' with the same dimensions as 'var'.
#'@param toptitle Top title of the figure, scalable with parameter
#' 'title_scale'.
#'@param sizetit Scale factor for the figure top title provided in parameter
#' 'toptitle'. Deprecated. Use 'title_scale' instead.
#'@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,colNA 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 attr(cols, 'na_color') if available by
#' default, where cols is the parameter 'cols' if provided or the vector of
#' colors returned by 'color_fun'. If not available, it takes 'pink' 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.
#'@param square Logical value to choose either to draw a coloured square for
#' each grid cell in 'var' (TRUE; default) or to draw contour lines and fill
#' the spaces in between with colours (FALSE). In the latter case,
#' 'filled.continents' will take the value FALSE if not specified.
#'@param filled.continents Colour to fill in drawn projected continents.
#' Takes the value gray(0.5) by default or, if 'square = FALSE', takes the
#' value FALSE. If set to FALSE, continents are not filled in.
#'@param filled.oceans A logical value or the color name to fill in drawn
#' projected oceans. The default value is FALSE. If it is TRUE, the default
#' colour is "light blue".
#'@param coast_color Colour of the coast line of the drawn projected continents.
#' Takes the value gray(0.5) by default.
#'@param coast_width Line width of the coast line of the drawn projected
#' continents. Takes the value 1 by default.
#'@param lake_color Colour of the lake or other water body inside continents.
#'@param contours Array of same dimensions as 'var' to be added to the plot
#' and displayed with contours. Parameter 'brks2' is required to define the
#' magnitude breaks for each contour curve. Disregarded if 'square = FALSE'.
#'@param brks2 Vector of magnitude breaks where to draw contour curves for the
#' array provided in 'contours' or if 'square = FALSE'.
#'@param contour_lwd Line width of the contour curves provided via 'contours'
#' and 'brks2', or if 'square = FALSE'.
#'@param contour_color Line color of the contour curves provided via 'contours'
#' and 'brks2', or if 'square = FALSE'.
#'@param contour_lty Line type of the contour curves. Takes 1 (solid) by
#' default. See help on 'lty' in par() for other accepted values.
aho
committed
#'@param contour_draw_label A logical value indicating whether to draw the
#' contour labels or not. The default value is TRUE.
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
#'@param contour_label_scale Scale factor for the superimposed labels when
#' drawing contour levels.
#'@param dots Array of same dimensions as 'var' or with dimensions
#' c(n, dim(var)), where n is the number of dot/symbol layers to add to the
#' plot. A value of TRUE at a grid cell will draw a dot/symbol on the
#' corresponding square of the plot. By default all layers provided in 'dots'
#' are plotted with dots, but a symbol can be specified for each of the
#' layers via the parameter 'dot_symbol'.
#'@param dot_symbol Single character/number or vector of characters/numbers
#' that correspond to each of the symbol layers specified in parameter 'dots'.
#' If a single value is specified, it will be applied to all the layers in
#' 'dots'. Takes 15 (centered square) by default. See 'pch' in par() for
#' additional accepted options.
#'@param dot_size Scale factor for the dots/symbols to be plotted, specified
#' in 'dots'. If a single value is specified, it will be applied to all
#' layers in 'dots'. Takes 1 by default.
#'@param arr_subsamp Subsampling factor to select a subset of arrows in
#' 'varu' and 'varv' to be drawn. Only one out of arr_subsamp arrows will
#' be drawn. Takes 1 by default.
#'@param arr_scale Scale factor for drawn arrows from 'varu' and 'varv'.
#' Takes 1 by default.
#'@param arr_ref_len Length of the refence arrow to be drawn as legend at the
#' bottom of the figure (in same units as 'varu' and 'varv', only affects the
#' legend for the wind or variable in these arrays). Defaults to 15.
#'@param arr_units Units of 'varu' and 'varv', to be drawn in the legend.
#' Takes 'm/s' by default.
#'@param arr_scale_shaft Parameter for the scale of the shaft of the arrows
#' (which also depend on the number of figures and the arr_scale parameter).
#' Defaults to 1.
#'@param arr_scale_shaft_angle Parameter for the scale of the angle of the
#' shaft of the arrows (which also depend on the number of figure and the
#' arr_scale parameter). Defaults to 1.
#'@param axelab Whether to draw longitude and latitude axes or not.
#' TRUE by default.
#'@param labW Whether to label the longitude axis with a 'W' instead of minus
#' for negative values. Defaults to FALSE.
#'@param lab_dist_x A numeric of the distance of the longitude labels to the
#' box borders. The default value is NULL and is automatically adjusted by
#' the function.
#'@param lab_dist_y A numeric of the distance of the latitude labels to the
#' box borders. The default value is NULL and is automatically adjusted by
#' the function.
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
#'@param intylat Interval between latitude ticks on y-axis, in degrees.
#' Defaults to 20.
#'@param intxlon Interval between latitude ticks on x-axis, in degrees.
#' Defaults to 20.
#'@param axes_tick_scale Scale factor for the tick lines along the longitude
#' and latitude axes.
#'@param axes_label_scale Scale factor for the labels along the longitude
#' and latitude axes.
#'@param drawleg Whether to plot a color bar (legend, key) or not. Defaults to
#' TRUE. It is not possible to plot the colour bar if 'add = TRUE'. Use
#' ColorBar() and the return values of PlotEquiMap() instead.
#'@param boxlim Limits of a box to be added to the plot, in degrees:
#' c(x1, y1, x2, y2). A list with multiple box specifications can also be
#' provided.
#'@param boxcol Colour of the box lines. A vector with a colour for each of
#' the boxes is also accepted. Defaults to 'purple2'.
#'@param boxlwd Line width of the box lines. A vector with a line width for
#' each of the boxes is also accepted. Defaults to 5.
#'@param margin_scale Scale factor for the margins around the map plot, with
#' the format c(y1, x1, y2, x2). Defaults to rep(1, 4). If drawleg = TRUE,
#' then margin_scale[1] is subtracted 1 unit.
#'@param title_scale Scale factor for the figure top title. Defaults to 1.
#'@param numbfig Number of figures in the layout the plot will be put into.
#' A higher numbfig will result in narrower margins and smaller labels,
#' axe labels, ticks, thinner lines, ... Defaults to 1.
#'@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 File width, in the units specified in the parameter size_units
#' (inches by default). Takes 8 by default.
#'@param height File height, in the units specified in the parameter
#' size_units (inches by default). Takes 5 by default.
#'@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 \dots Arguments to be passed to the method. Only accepts the following
#' graphical parameters:\cr
#' adj ann ask bg bty cex.sub cin col.axis col.lab col.main col.sub cra crt
#' csi cxy err family fg font font.axis font.lab font.main font.sub lend
#' lheight ljoin lmitre mex mfcol mfrow mfg mkh omd omi page pch pin plt
#' pty smo srt 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 colouring the map (and legend if drawleg = TRUE).
#'}
#'\item{cols}{
#' Colours used for colouring the map (and legend if drawleg = TRUE). 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
#'# See examples on Load() to understand the first lines in this example
#' \dontrun{
#'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')
#' c('observation'), startDates,
#' leadtimemin = 1,
#' leadtimemax = 4,
#' output = 'lonlat',
#' latmin = 27, latmax = 48,
#' lonmin = -12, lonmax = 40)
#' }
#'PlotEquiMap(sampleData$mod[1, 1, 1, 1, , ], sampleData$lon, sampleData$lat,
#' toptitle = 'Predicted sea surface temperature for Nov 1960 from 1st Nov',
#' sizetit = 0.5)
#'@import graphics GEOmap geomapdata maps
#'@importFrom grDevices dev.cur dev.new dev.off gray
#'@importFrom stats cor
#'@export
PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL,
toptitle = NULL, sizetit = NULL, units = NULL,
brks = NULL, cols = NULL, bar_limits = NULL,
triangle_ends = NULL, col_inf = NULL, col_sup = NULL,
colNA = NULL, color_fun = clim.palette(),
square = TRUE, filled.continents = NULL,
coast_color = NULL, coast_width = 1, lake_color = NULL,
contours = NULL, brks2 = NULL, contour_lwd = 0.5,
contour_color = 'black', contour_lty = 1,
aho
committed
contour_draw_label = TRUE, contour_label_scale = 1,
dots = NULL, dot_symbol = 4, dot_size = 1,
arr_subsamp = floor(length(lon) / 30), arr_scale = 1,
arr_ref_len = 15, arr_units = "m/s",
arr_scale_shaft = 1, arr_scale_shaft_angle = 1,
axelab = TRUE, labW = FALSE,
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
293
294
295
296
297
298
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
intylat = 20, intxlon = 20,
axes_tick_scale = 1, axes_label_scale = 1,
drawleg = TRUE, subsampleg = NULL,
bar_extra_labels = NULL, draw_bar_ticks = TRUE,
draw_separators = FALSE, triangle_ends_scale = 1,
bar_label_digits = 4, bar_label_scale = 1,
units_scale = 1, bar_tick_scale = 1,
bar_extra_margin = rep(0, 4),
boxlim = NULL, boxcol = 'purple2', boxlwd = 5,
margin_scale = rep(1, 4), title_scale = 1,
numbfig = NULL, fileout = NULL,
width = 8, height = 5, size_units = 'in',
res = 100, ...) {
# Process the user graphical parameters that may be passed in the call
## Graphical parameters to exclude
excludedArgs <- c("cex", "cex.axis", "cex.lab", "cex.main", "col", "din", "fig", "fin", "lab", "las", "lty", "lwd", "mai", "mar", "mgp", "new", "oma", "ps", "tck")
userArgs <- .FilterUserGraphicArgs(excludedArgs, ...)
# 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
}
# Preliminar check of dots, contours, varu, varv, lon, lat
if (!is.null(dots)) {
if (!is.array(dots) || !(length(dim(dots)) %in% c(2, 3))) {
stop("Parameter 'dots' must be a logical array with two or three dimensions.")
}
if (length(dim(dots)) == 2) {
dim(dots) <- c(1, dim(dots))
}
}
if (!is.null(contours)) {
if (!is.array(contours) || !(length(dim(contours)) == 2)) {
stop("Parameter 'contours' must be a numerical array with two dimensions.")
}
}
if (!is.null(varu) && !is.null(varv)) {
if (!is.array(varu) || !(length(dim(varu)) == 2)) {
stop("Parameter 'varu' must be a numerical array with two dimensions.")
}
if (!is.array(varv) || !(length(dim(varv)) == 2)) {
stop("Parameter 'varv' must be a numerical array with two dimensions.")
}
} else if (!is.null(varu) || !is.null(varv)) {
stop("Only one of the components 'varu' or 'varv' has been provided. Both must be provided.")
}
if (!is.numeric(lon) || !is.numeric(lat)) {
stop("Parameters 'lon' and 'lat' must be numeric vectors.")
}
# Check var
if (!is.array(var)) {
stop("Parameter 'var' must be a numeric array.")
}
if (length(dim(var)) > 2) {
var <- drop(var)
dim(var) <- head(c(dim(var), 1, 1), 2)
}
if (length(dim(var)) > 2) {
stop("Parameter 'var' must be a numeric array with two dimensions. See PlotMultiMap() for multi-pannel maps or AnimateMap() for animated maps.")
} else if (length(dim(var)) < 2) {
stop("Parameter 'var' must be a numeric array with two dimensions.")
}
dims <- dim(var)
# Transpose the input matrices because the base plot functions work directly
# with dimensions c(lon, lat).
transpose <- FALSE
if (!is.null(names(dims))) {
if (any(names(dims) %in% .KnownLonNames()) &&
any(names(dims) %in% .KnownLatNames())) {
if (which(names(dims) %in% .KnownLonNames()) != 1) {
transpose <- TRUE
}
}
}
if (dims[1] != length(lon) || dims[2] != length(lat)) {
if (dims[1] == length(lat) && dims[2] == length(lon)) {
transpose <- TRUE
}
}
if (transpose) {
var <- t(var)
if (!is.null(varu)) varu <- t(varu)
if (!is.null(varv)) varv <- t(varv)
if (!is.null(contours)) contours <- t(contours)
if (!is.null(dots)) dots <- aperm(dots, c(1, 3, 2))
dims <- dim(var)
}
# Check lon
if (length(lon) != dims[1]) {
stop("Parameter 'lon' must have as many elements as the number of cells along longitudes in the input array 'var'.")
}
# Check lat
if (length(lat) != dims[2]) {
stop("Parameter 'lat' must have as many elements as the number of cells along longitudes in the input array 'var'.")
}
# Check varu and varv
if (!is.null(varu) && !is.null(varv)) {
if (dim(varu)[1] != dims[1] || dim(varu)[2] != dims[2]) {
stop("Parameter 'varu' must have same number of longitudes and latitudes as 'var'.")
}
if (dim(varv)[1] != dims[1] || dim(varv)[2] != dims[2]) {
stop("Parameter 'varv' must have same number of longitudes and latitudes as 'var'.")
}
}
# Check toptitle
if (is.null(toptitle) || is.na(toptitle)) {
toptitle <- ''
}
if (!is.character(toptitle)) {
stop("Parameter 'toptitle' must be a character string.")
}
# Check sizetit
if (!is.null(sizetit)) {
.warning("Parameter 'sizetit' is obsolete. Use 'title_scale' instead.")
if (!is.numeric(sizetit) || length(sizetit) != 1) {
stop("Parameter 'sizetit' must be a single numeric value.")
}
title_scale <- sizetit
}
var_limits <- c(min(var, na.rm = TRUE), max(var, na.rm = TRUE))
# Check: brks, cols, subsampleg, bar_limits, color_fun, bar_extra_labels, draw_bar_ticks
# draw_separators, triangle_ends_scale, label_scale, units, units_scale,
# bar_label_digits
# Build: brks, cols, bar_limits, col_inf, col_sup
colorbar <- ColorBar(brks, cols, FALSE, subsampleg, bar_limits, var_limits,
triangle_ends, col_inf, col_sup, color_fun, FALSE,
extra_labels = bar_extra_labels, draw_ticks = draw_bar_ticks,
draw_separators = draw_separators,
triangle_ends_scale = triangle_ends_scale,
label_scale = bar_label_scale, title = units,
title_scale = units_scale, tick_scale = bar_tick_scale,
extra_margin = bar_extra_margin, label_digits = bar_label_digits)
brks <- colorbar$brks
cols <- colorbar$cols
col_inf <- colorbar$col_inf
col_sup <- colorbar$col_sup
bar_limits <- c(head(brks, 1), tail(brks, 1))
# Check colNA
if (is.null(colNA)) {
if ('na_color' %in% names(attributes(cols))) {
colNA <- attr(cols, 'na_color')
if (!.IsColor(colNA)) {
stop("The 'na_color' provided as attribute of the colour vector must be a valid colour identifier.")
}
} else {
colNA <- 'pink'
}
} else if (!.IsColor(colNA)) {
stop("Parameter 'colNA' must be a valid colour identifier.")
}
# Check square
if (!is.logical(square)) {
stop("Parameter 'square' must be logical.")
}
# Check filled.continents
if (is.null(filled.continents)) {
if (!square) {
filled.continents <- FALSE
} else {
filled.continents <- TRUE
}
}
if (!.IsColor(filled.continents) && !is.logical(filled.continents)) {
stop("Parameter 'filled.continents' must be logical or a colour identifier.")
} else if (!is.logical(filled.continents)) {
continent_color <- filled.continents
filled.continents <- TRUE
continent_color <- gray(0.5)
}
# Check filled.oceans
if (!.IsColor(filled.oceans) & !is.logical(filled.oceans)) {
stop("Parameter 'filled.oceans' must be logical or a colour identifier.")
} else if (!is.logical(filled.oceans)) {
ocean_color <- filled.oceans
filled.oceans <- TRUE
} else if (filled.oceans) {
ocean_color <- "light blue"
}
# Check coast_color
if (is.null(coast_color)) {
if (filled.continents) {
coast_color <- continent_color
} else {
coast_color <- 'black'
}
}
if (!.IsColor(coast_color)) {
stop("Parameter 'coast_color' must be a valid colour identifier.")
}
# Check coast_width
if (!is.numeric(coast_width)) {
stop("Parameter 'coast_width' must be numeric.")
}
# Check lake_color
if (!is.null(lake_color)) {
# if (filled.continents) {
# lake_color <- 'white'
# }
# } else {
if (!.IsColor(lake_color)) {
stop("Parameter 'lake_color' must be a valid colour identifier.")
}
}
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
# Check contours
if (!is.null(contours)) {
if (dim(contours)[1] != dims[1] || dim(contours)[2] != dims[2]) {
stop("Parameter 'contours' must have the same number of longitudes and latitudes as 'var'.")
}
}
# Check brks2
if (is.null(brks2)) {
if (is.null(contours)) {
if (!square) {
brks2 <- brks
contours <- var
}
} else {
ll <- signif(min(contours, na.rm = TRUE), 2)
ul <- signif(max(contours, na.rm = TRUE), 2)
brks2 <- signif(seq(ll, ul, length.out = length(brks)), 2)
}
}
# Check contour_lwd
if (!is.numeric(contour_lwd)) {
stop("Parameter 'contour_lwd' must be numeric.")
}
# Check contour_color
if (!.IsColor(contour_color)) {
stop("Parameter 'contour_color' must be a valid colour identifier.")
}
# Check contour_lty
if (!is.numeric(contour_lty) && !is.character(contour_lty)) {
stop("Parameter 'contour_lty' must be either a number or a character string.")
}
aho
committed
# Check contour_draw_label
if (!is.logical(contour_draw_label)) {
stop("Parameter 'contour_draw_label' must be logical.")
}
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
# Check contour_label_scale
if (!is.numeric(contour_label_scale)) {
stop("Parameter 'contour_label_scale' must be numeric.")
}
# Check dots, dot_symbol and dot_size
if (!is.null(dots)) {
if (dim(dots)[2] != dims[1] || dim(dots)[3] != dims[2]) {
stop("Parameter 'dots' must have the same number of longitudes and latitudes as 'var'.")
}
if (!is.numeric(dot_symbol) && !is.character(dot_symbol)) {
stop("Parameter 'dot_symbol' must be a numeric or character string vector.")
}
if (length(dot_symbol) == 1) {
dot_symbol <- rep(dot_symbol, dim(dots)[1])
} else if (length(dot_symbol) < dim(dots)[1]) {
stop("Parameter 'dot_symbol' does not contain enough symbols.")
}
if (!is.numeric(dot_size)) {
stop("Parameter 'dot_size' must be numeric.")
}
if (length(dot_size) == 1) {
dot_size <- rep(dot_size, dim(dots)[1])
} else if (length(dot_size) < dim(dots)[1]) {
stop("Parameter 'dot_size' does not contain enough sizes.")
}
}
# Check arrow parameters
if (!is.numeric(arr_subsamp)) {
stop("Parameter 'arr_subsamp' must be numeric.")
}
if (!is.numeric(arr_scale)) {
stop("Parameter 'arr_scale' must be numeric.")
}
if (!is.numeric(arr_ref_len)) {
stop("Parameter 'arr_ref_len' must be numeric.")
}
if (!is.character(arr_units)) {
stop("Parameter 'arr_units' must be character.")
}
if (!is.numeric(arr_scale_shaft)) {
stop("Parameter 'arr_scale_shaft' must be numeric.")
}
if (!is.numeric(arr_scale_shaft_angle)) {
stop("Parameter 'arr_scale_shaft_angle' must be numeric.")
}
# Check axis parameters
if (!is.logical(axelab)) {
stop("Parameter 'axelab' must be logical.")
}
if (!is.logical(labW)) {
stop("Parameter 'labW' must be logical.")
}
if (!is.null(lab_dist_x)) {
if (!is.numeric(lab_dist_x)) {
stop("Parameter 'lab_dist_x' must be numeric.")
}
}
if (!is.null(lab_dist_y)) {
if (!is.numeric(lab_dist_y)) {
stop("Parameter 'lab_dist_y' must be numeric.")
}
}
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
if (!is.numeric(intylat)) {
stop("Parameter 'intylat' must be numeric.")
} else {
intylat <- round(intylat)
}
if (!is.numeric(intxlon)) {
stop("Parameter 'intxlon' must be numeric.")
} else {
intxlon <- round(intxlon)
}
# Check legend parameters
if (!is.logical(drawleg)) {
stop("Parameter 'drawleg' must be logical.")
}
# Check box parameters
if (!is.null(boxlim)) {
if (!is.list(boxlim)) {
boxlim <- list(boxlim)
}
for (i in 1:length(boxlim)) {
if (!is.numeric(boxlim[[i]]) || length(boxlim[[i]]) != 4) {
stop("Parameter 'boxlim' must be a a numeric vector or a list of numeric vectors of length 4 (with W, S, E, N box limits).")
}
}
if (!is.character(boxcol)) {
stop("Parameter 'boxcol' must be a character string or a vector of character strings.")
} else {
if (length(boxlim) != length(boxcol)) {
if (length(boxcol) == 1) {
boxcol <- rep(boxcol, length(boxlim))
} else {
stop("Parameter 'boxcol' must have a colour for each box in 'boxlim' or a single colour for all boxes.")
}
}
}
if (!is.numeric(boxlwd)) {
stop("Parameter 'boxlwd' must be numeric.")
} else {
if (length(boxlim) != length(boxlwd)) {
if (length(boxlwd) == 1) {
boxlwd <- rep(boxlwd, length(boxlim))
} else {
stop("Parameter 'boxlwd' must have a line width for each box in 'boxlim' or a single line width for all boxes.")
}
}
}
}
# Check margin_scale
if (!is.numeric(margin_scale) || length(margin_scale) != 4) {
stop("Parameter 'margin_scale' must be a numeric vector of length 4.")
}
# Check title_scale
if (!is.numeric(title_scale)) {
stop("Parameter 'title_scale' must be numeric.")
}
# Check axes_tick_scale
if (!is.numeric(axes_tick_scale)) {
stop("Parameter 'axes_tick_scale' must be numeric.")
}
# Check axes_label_scale
if (!is.numeric(axes_label_scale)) {
stop("Parameter 'axes_label_scale' must be numeric.")
}
# Check numbfig
if (!is.null(numbfig)) {
if (!is.numeric(numbfig)) {
stop("Parameter 'numbfig' must be numeric.")
} else {
numbfig <- round(numbfig)
scale <- 1 / numbfig ** 0.3
axes_tick_scale <- axes_tick_scale * scale
axes_label_scale <- axes_label_scale * scale
title_scale <- title_scale * scale
margin_scale <- margin_scale * scale
arr_scale <- arr_scale * scale
dot_size <- dot_size * scale
contour_label_scale <- contour_label_scale * scale
contour_lwd <- contour_lwd * scale
}
}
#library(GEOmap)
#library(geomapdata)
#library(maps)
utils::data(coastmap, package = 'GEOmap', envir = environment())
#
# Input arguments
# ~~~~~~~~~~~~~~~~~
#
latb <- sort(lat, index.return = TRUE)
dlon <- lon[2:dims[1]] - lon[1:(dims[1] - 1)]
wher <- which(dlon > (mean(dlon) + 1))
if (length(wher) > 0) {
lon[(wher + 1):dims[1]] <- lon[(wher + 1):dims[1]] - 360
}
lonb <- sort(lon, index.return = TRUE)
latmin <- floor(min(lat) / 10) * 10
latmax <- ceiling(max(lat) / 10) * 10
lonmin <- floor(min(lon) / 10) * 10
lonmax <- ceiling(max(lon) / 10) * 10
if (min(lon) < 0) {
continents <- 'world'
} else {
continents <- 'world2'
}
#
# Plotting the map
# ~~~~~~~~~~~~~~~~~~
#
# Open connection to graphical device
if (!is.null(fileout)) {
saveToFile(fileout)
} else if (names(dev.cur()) == 'null device') {
dev.new(units = size_units, res = res, width = width, height = height)
}
#
# Defining the layout
# ~~~~~~~~~~~~~~~~~~~~~
#
if (drawleg) {
margin_scale[1] <- margin_scale[1] - 1
}
margins <- rep(0.4, 4) * margin_scale
cex_title <- 2 * title_scale
cex_axes_labels <- 1.3 * axes_label_scale
cex_axes_ticks <- -0.5 * axes_tick_scale
spaceticklab <- 0
if (axelab) {
ypos <- seq(latmin, latmax, intylat)
xpos <- seq(lonmin, lonmax, intxlon)
letters <- array('', length(ypos))
letters[ypos < 0] <- 'S'
letters[ypos > 0] <- 'N'
ylabs <- paste(as.character(abs(ypos)), letters, sep = '')
letters <- array('', length(xpos))
if (labW) {
xpos2 <- xpos
xpos2[xpos2 > 180] <- 360 - xpos2[xpos2 > 180]
}
letters[xpos < 0] <- 'W'
letters[xpos > 0] <- 'E'
if (labW) {
letters[xpos == 0] <- ' '
letters[xpos == 180] <- ' '
letters[xpos > 180] <- 'W'
xlabs <- paste(as.character(abs(xpos2)), letters, sep = '')
} else {
xlabs <- paste(as.character(abs(xpos)), letters, sep = '')
}
spaceticklab <- max(-cex_axes_ticks, 0)
margins[1] <- margins[1] + 1.2 * cex_axes_labels + spaceticklab
margins[2] <- margins[2] + 1.2 * cex_axes_labels + spaceticklab
}
bar_extra_margin[2] <- bar_extra_margin[2] + margins[2]
bar_extra_margin[4] <- bar_extra_margin[4] + margins[4]
if (toptitle != '') {
margins[3] <- margins[3] + cex_title + 1
}
if (!is.null(varu)) {
margins[1] <- margins[1] + 2.2 * units_scale
}
if (drawleg) {
layout(matrix(1:2, ncol = 1, nrow = 2), heights = c(5, 1))
}
plot.new()
# Load the user parameters
par(userArgs)
par(mar = margins, cex.main = cex_title, cex.axis = cex_axes_labels,
mgp = c(0, spaceticklab, 0), las = 0)
#NOTE: Here creates the window for later plot. If 'usr' for par() is not specified,
# use the lat/lon as the borders. If 'usr' is specified, use the assigned values.
if (is.null(userArgs$usr)) {
#NOTE: The grids are assumed to be equally spaced
xlim_cal <- c(lonb$x[1] - (lonb$x[2] - lonb$x[1]) / 2,
lonb$x[length(lonb$x)] + (lonb$x[2] - lonb$x[1]) / 2)
ylim_cal <- c(latb$x[1] - (latb$x[2] - latb$x[1]) / 2,
latb$x[length(latb$x)] + (latb$x[2] - latb$x[1]) / 2)
plot.window(xlim = xlim_cal, ylim = ylim_cal, xaxs = 'i', yaxs = 'i')
# Below is Old code. The border grids are only half plotted.
# plot.window(xlim = range(lonb$x, finite = TRUE), ylim = range(latb$x, finite = TRUE),
# xaxs = 'i', yaxs = 'i')
} else {
plot.window(xlim = par("usr")[1:2], ylim = par("usr")[3:4], xaxs = 'i', yaxs = 'i')
}
lab_distance_y <- ifelse(is.null(lab_dist_y), spaceticklab + 0.2, lab_dist_y)
lab_distance_x <- ifelse(is.null(lab_dist_x), spaceticklab + cex_axes_labels / 2 - 0.3, lab_dist_x)
axis(2, at = ypos, labels = ylabs, cex.axis = cex_axes_labels, tcl = cex_axes_ticks,
axis(1, at = xpos, labels = xlabs, cex.axis = cex_axes_labels, tcl = cex_axes_ticks,
}
title(toptitle, cex.main = cex_title)
rect(par("usr")[1], par("usr")[3], par("usr")[2], par("usr")[4], col = colNA)
col_inf_image <- ifelse(is.null(col_inf), colNA, col_inf)
col_sup_image <- ifelse(is.null(col_sup), colNA, col_sup)
if (square) {
image(lonb$x, latb$x, var[lonb$ix, latb$ix], col = c(col_inf_image, cols, col_sup_image),
breaks = c(-.Machine$double.xmax, brks, .Machine$double.xmax),
axes = FALSE, xlab = "", ylab = "", add = TRUE)
} else {
.filled.contour(lonb$x, latb$x, var[lonb$ix, latb$ix],
levels = c(.Machine$double.xmin, brks, .Machine$double.xmax),
col = c(col_inf_image, cols, col_sup_image))
}
if (!is.null(contours)) {
#NOTE: 'labcex' is the absolute size of contour labels. Parameter 'contour_label_scale'
# is provided in PlotEquiMap() but it was not used. Here, 'cex_axes_labels' was used
# and it was calculated from 'axes_label_scale', the size of lat/lon axis label.
# It is changed to use contour_label_scale*par('cex').
contour(lonb$x, latb$x, contours[lonb$ix, latb$ix], levels = brks2,
method = "edge", add = TRUE,
# labcex = cex_axes_labels,
labcex = contour_label_scale * par("cex"),
lwd = contour_lwd, lty = contour_lty,
aho
committed
col = contour_color, drawlabels = contour_draw_label)
}
#
# Adding black dots or symbols
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#
if (!is.null(dots)) {
data_avail <- !is.na(var)
for (counter in 1:(dim(dots)[1])) {
points <- which(dots[counter, , ] & data_avail, arr.ind = TRUE)
points(lon[points[, 1]], lat[points[, 2]],
pch = dot_symbol[counter],
cex = dot_size[counter] * 3 / sqrt(sqrt(length(var))),
lwd = dot_size[counter] * 3 / sqrt(sqrt(length(var))))
}
}
#
# Plotting continents
# ~~~~~~~~~~~~~~~~~~~~~
#
# maps::map has the global map range [0, 360] or [-180, 180].
# Set xlim so lon = 0 won't show a straight line when lon = [0, 359].
# NOTE: It works except Antartic area. Don't know why. ylim is also set
# but it doesn't work.
if (continents == 'world') { # [-180, 180]
xlim_conti <- c(-179.99, 179.99)
} else { # [0, 360]
xlim_conti <- c(0.01, 359.99)
}
old_lwd <- par('lwd')
par(lwd = coast_width)
# If [0, 360], use GEOmap; if [-180, 180], use maps
if (min(lon) >= 0) {
ylat <- latmin:latmax
xlon <- lonmin:lonmax
proj <- GEOmap::setPROJ(1, LON0 = mean(xlon),
LAT0 = mean(ylat), LATS = ylat, LONS = xlon)
lakes <- which(coastmap$STROKES$col == "blue")
par(new = TRUE)
if (filled.continents) {
coastmap$STROKES$col[which(coastmap$STROKES$col != "blue")] <- continent_color
if (is.null(lake_color)) {
coastmap$STROKES$col[lakes] <- continent_color
} else {
coastmap$STROKES$col[lakes] <- lake_color #"white"
}
GEOmap::plotGEOmap(coastmap, PROJ = proj, border = coast_color,
add = TRUE, lwd = coast_width)
} else {
coastmap$STROKES$col[which(coastmap$STROKES$col != "blue")] <- coast_color
if (is.null(lake_color)) {
coastmap$STROKES$col[lakes] <- coast_color
} else {
coastmap$STROKES$col[lakes] <- lake_color #"white"
}
GEOmap::plotGEOmap(coastmap, PROJ = proj, #MAPcol = coast_color,
add = TRUE, lwd = coast_width, MAPstyle = 2)
# [-180, 180]
coast <- map(continents, interior = FALSE, wrap = TRUE,
xlim = xlim_conti, ylim = c(-89.99, 89.99),
fill = filled.continents, add = TRUE, plot = FALSE)
if (filled.continents) {
polygon(coast, col = continent_color, border = coast_color, lwd = coast_width)
} else {
lines(coast, col = coast_color, lwd = coast_width)
}
if (!is.null(lake_color)) {
map('lakes', add = TRUE, fill = filled.continents, col = lake_color)
}
# filled.oceans
if (filled.oceans) {
old_lwd <- par('lwd')
par(lwd = coast_width)
outline <- map(continents, fill = T, plot = FALSE) # must be fill = T
xbox <- xlim_conti + c(-2, 2)
ybox <- c(-92, 92)
outline$x <- c(outline$x, NA, c(xbox, rev(xbox), xbox[1]))
outline$y <- c(outline$y, NA, rep(ybox, each = 2), ybox[1])
polypath(outline, col = ocean_color, rule = 'evenodd', border = NA)
par(lwd = old_lwd)
}
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
box()
# Draw rectangle on the map
if (!is.null(boxlim)) {
counter <- 1
for (box in boxlim) {
if (box[1] > box[3]) {
box[1] <- box[1] - 360
}
if (length(box) != 4) {
stop(paste("The", counter, "st box defined in the parameter 'boxlim' is ill defined."))
} else if (box[2] < latmin || box[4] > latmax ||
box[1] < lonmin || box[3] > lonmax) {
stop(paste("The limits of the", counter, "st box defined in the parameter 'boxlim' are invalid."))
} else if (box[1] < 0 && box[3] > 0) {
#segments south
segments(box[1], box[2], 0, box[2], col = boxcol[counter], lwd = boxlwd[counter])
segments(0, box[2], box[3], box[2], col = boxcol[counter], lwd = boxlwd[counter])
#segments north
segments(box[1], box[4], 0, box[4], col = boxcol[counter], lwd = boxlwd[counter])
segments(0, box[4], box[3], box[4], col = boxcol[counter], lwd = boxlwd[counter])
#segments west
segments(box[1], box[2], box[1], box[4], col = boxcol[counter],
lwd = boxlwd[counter])
#segments est
segments(box[3], box[2], box[3],box[4], col = boxcol[counter],
lwd = boxlwd[counter])
} else {
rect(box[1], box[2], box[3], box[4], border = boxcol[counter], col = NULL,
lwd = boxlwd[counter], lty = 'solid')
}
counter <- counter + 1
}
}
#
# PlotWind
# ~~~~~~~~~~
#
if (!is.null(varu) && !is.null(varv)) {
# Create a two dimention array of longitude and latitude
lontab <- InsertDim(lonb$x, 2, length(latb$x), name = 'lat')
lattab <- InsertDim(latb$x, 1, length(lonb$x), name = 'lon')
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
varplotu <- varu[lonb$ix, latb$ix]
varplotv <- varv[lonb$ix, latb$ix]
# Select a subsample af the points to an arrow
#for each "subsample" grid point
sublon <- seq(1,length(lon), arr_subsamp)
sublat <- seq(1,length(lat), arr_subsamp)
uaux <- lontab[sublon, sublat] + varplotu[sublon, sublat] * 0.5 * arr_scale
vaux <- lattab[sublon, sublat] + varplotv[sublon, sublat] * 0.5 * arr_scale
lenshaft <- 0.18 * arr_scale * arr_scale_shaft
angleshaft <- 12 * arr_scale_shaft_angle
# Plot Wind
arrows(lontab[sublon, sublat], lattab[sublon, sublat],
uaux, vaux,
angle = angleshaft,
length = lenshaft)
# Plotting an arrow at the bottom of the plot for the legend
posarlon <- lonb$x[1] + (lonmax - lonmin) * 0.1
posarlat <- latmin - ((latmax - latmin) + 1) / par('pin')[2] *
(spaceticklab + 0.2 + cex_axes_labels + 0.6 * units_scale) * par('csi')
arrows(posarlon, posarlat,
posarlon + 0.5 * arr_scale * arr_ref_len, posarlat,
length = lenshaft, angle = angleshaft,
xpd = TRUE)
#save the parameter value
xpdsave <- par('xpd')
#desactivate xpd to be able to plot in margen
par(xpd = NA)
#plot text
mtext(paste(as.character(arr_ref_len), arr_units, sep = ""),
line = spaceticklab + 0.2 + cex_axes_labels + 1.2 * units_scale, side = 1,
at = posarlon + (0.5 * arr_scale * arr_ref_len) / 2,
cex = units_scale)
#come back to the previous xpd value
par(xpd = xpdsave)
}
#
# Colorbar
# ~~~~~~~~~~
#
if (drawleg) {
ColorBar(brks, cols, FALSE, subsampleg, bar_limits, var_limits,
triangle_ends, col_inf = col_inf, col_sup = col_sup,
extra_labels = bar_extra_labels, draw_ticks = draw_bar_ticks,
draw_separators = draw_separators, title = units,
title_scale = units_scale, triangle_ends_scale = triangle_ends_scale,
label_scale = bar_label_scale, tick_scale = bar_tick_scale,
extra_margin = bar_extra_margin, label_digits = bar_label_digits)
}
# If the graphic was saved to file, close the connection with the device
if (!is.null(fileout)) dev.off()
invisible(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup))
}