From 3c830c382dc6c94a6ba3eae9a793c32f1762760b Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 3 May 2021 17:49:15 +0200 Subject: [PATCH 1/3] Add contour function. --- R/PlotStereoMap.R | 91 ++++++++++++++++++++++++++++++++++++++++++++ man/PlotStereoMap.Rd | 25 ++++++++++++ 2 files changed, 116 insertions(+) diff --git a/R/PlotStereoMap.R b/R/PlotStereoMap.R index d4e8e2d..cab3b58 100644 --- a/R/PlotStereoMap.R +++ b/R/PlotStereoMap.R @@ -58,6 +58,19 @@ #' 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 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. +#'@param brks2 Vector of magnitude breaks where to draw contour curves for the +#' array provided in 'contours'. +#'@param contour_lwd Line width of the contour curves provided via 'contours' +#' and 'brks2'. +#'@param contour_color Line color of the contour curves provided via 'contours' +#' and 'brks2'. +#'@param contour_lty Line type of the contour curves. Takes 1 (solid) by +#' default. See help on 'lty' in par() for other accepted values. +#'@param contour_label_scale Scale factor for the superimposed labels when +#' drawing contour levels. The default value is 0.6. #'@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 @@ -144,6 +157,9 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), colNA = NULL, color_fun = clim.palette(), filled.continents = FALSE, coast_color = NULL, coast_width = 1, + contours = NULL, brks2 = NULL, contour_lwd = 0.5, + contour_color = 'black', contour_lty = 1, + contour_label_scale = 0.6, dots = NULL, dot_symbol = 4, dot_size = 0.8, intlat = 10, drawleg = TRUE, subsampleg = NULL, @@ -309,6 +325,57 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), if (!is.numeric(coast_width)) { stop("Parameter 'coast_width' must be numeric.") } + # Check contours + if (!is.null(contours)) { + if (!is.array(contours)) { + stop("Parameter 'contours' must be a numeric array.") + } + if (length(dim(contours)) > 2) { + contours <- drop(contours) + dim(contours) <- head(c(dim(contours), 1, 1), 2) + } + if (length(dim(contours)) > 2) { + stop("Parameter 'contours' must be a numeric array with two dimensions.") + } else if (length(dim(contours)) < 2) { + stop("Parameter 'contours' must be a numeric array with two dimensions.") + } + # Transpose the input matrices because the base plot functions work directly + # with dimensions c(lon, lat). + if (dim(contours)[1] == dims[2] & dim(contours)[2] == dims[1]) { + contours <- t(contours) + } else { + stop("Parameter 'contours' must have the same number of longitudes and latitudes as 'var'.") + } + } + + # Check brks2 + if (is.null(brks2)) { + if (!is.null(contours)) { + 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.") + } + + # 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)) { @@ -482,6 +549,30 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), } } } + + # contours + if (!is.null(contours)) { + nbrks2 <- length(brks2) + for (n_brks2 in 1:nbrks2) { + cl <- grDevices::contourLines(x = lon, y = lat[which(lat >= latlims[1] & lat <= latlims[2])], + z = contours[, which(lat >= latlims[1] & lat <= latlims[2])], + levels = brks2[n_brks2]) + if (length(cl) > 0) { + for (i in seq_along(cl)) { + xy <- mapproj::mapproject(cl[[i]]$x, cl[[i]]$y) + xc <- xy$x + yc <- xy$y + nc <- length(xc) + lines(xc, yc, col = contour_color) #, lwd=lwd[n_brks2], lty=lty[n_brks2]) + + # draw label + text(xc[1], yc[1], as.character(round(brks2[n_brks2], 2)), cex = contour_label_scale) +# text(xc[labelj], yc[labelj], label, col=col[n_brks2], srt=angle*180/pi, cex=labcex[n_brks2]) + } + } + } + } + # Draw the dots if (!is.null(dots)) { numbfig <- 1 # for compatibility with PlotEquiMap code diff --git a/man/PlotStereoMap.Rd b/man/PlotStereoMap.Rd index 95c2f71..5393eec 100644 --- a/man/PlotStereoMap.Rd +++ b/man/PlotStereoMap.Rd @@ -23,6 +23,12 @@ PlotStereoMap( filled.continents = FALSE, coast_color = NULL, coast_width = 1, + contours = NULL, + brks2 = NULL, + contour_lwd = 0.5, + contour_color = "black", + contour_lty = 1, + contour_label_scale = 0.6, dots = NULL, dot_symbol = 4, dot_size = 0.8, @@ -116,6 +122,25 @@ continents. Takes the value gray(0.5) by default.} \item{coast_width}{Line width of the coast line of the drawn projected continents. Takes the value 1 by default.} +\item{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.} + +\item{brks2}{Vector of magnitude breaks where to draw contour curves for the +array provided in 'contours'.} + +\item{contour_lwd}{Line width of the contour curves provided via 'contours' +and 'brks2'.} + +\item{contour_color}{Line color of the contour curves provided via 'contours' +and 'brks2'.} + +\item{contour_lty}{Line type of the contour curves. Takes 1 (solid) by +default. See help on 'lty' in par() for other accepted values.} + +\item{contour_label_scale}{Scale factor for the superimposed labels when +drawing contour levels. The default value is 0.6.} + \item{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 -- GitLab From 3d1ad03a8290a241ff4a43d3c784a7d099ebd48a Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 4 May 2021 17:06:55 +0200 Subject: [PATCH 2/3] Use 'contour_label_scale' as cex for contour(). --- R/PlotEquiMap.R | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/R/PlotEquiMap.R b/R/PlotEquiMap.R index cf0442f..eae709c 100644 --- a/R/PlotEquiMap.R +++ b/R/PlotEquiMap.R @@ -732,9 +732,15 @@ PlotEquiMap <- function(var, lon, lat, varu = NULL, varv = NULL, 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, lwd = contour_lwd, lty = contour_lty, + method = "edge", add = TRUE, +# labcex = cex_axes_labels, + labcex = contour_label_scale * par("cex"), + lwd = contour_lwd, lty = contour_lty, col = contour_color) } -- GitLab From 12ba4c4d97c61242d28db0e1de38bd3232156991 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 4 May 2021 17:07:16 +0200 Subject: [PATCH 3/3] Refine labels of contour lines --- R/PlotStereoMap.R | 77 +++++++++++++++++++++++++++++++++++++------- man/PlotStereoMap.Rd | 15 ++++++--- 2 files changed, 76 insertions(+), 16 deletions(-) diff --git a/R/PlotStereoMap.R b/R/PlotStereoMap.R index cab3b58..e347775 100644 --- a/R/PlotStereoMap.R +++ b/R/PlotStereoMap.R @@ -61,14 +61,19 @@ #'@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. -#'@param brks2 Vector of magnitude breaks where to draw contour curves for the -#' array provided in 'contours'. +#'@param brks2 A numeric value or vector of magnitude breaks where to draw +#' contour curves for the array provided in 'contours'. If it is a number, it +#' represents the number of breaks (n) that defines (n - 1) intervals to +#' classify 'contours'. #'@param contour_lwd Line width of the contour curves provided via 'contours' -#' and 'brks2'. -#'@param contour_color Line color of the contour curves provided via 'contours' +#' and 'brks2'. The default value is 0.5. +#'@param contour_color Line color of the contour curves provided via 'contours' #' and 'brks2'. #'@param contour_lty Line type of the contour curves. Takes 1 (solid) by #' default. See help on 'lty' in par() for other accepted values. +#'@param contour_label_draw A logical value indicating whether to draw the +#' contour labels (TRUE) or not (FALSE) when 'contours' is used. The default +#' value is TRUE. #'@param contour_label_scale Scale factor for the superimposed labels when #' drawing contour levels. The default value is 0.6. #'@param dots Array of same dimensions as 'var' or with dimensions @@ -159,7 +164,7 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), coast_width = 1, contours = NULL, brks2 = NULL, contour_lwd = 0.5, contour_color = 'black', contour_lty = 1, - contour_label_scale = 0.6, + contour_label_draw = TRUE, contour_label_scale = 0.6, dots = NULL, dot_symbol = 4, dot_size = 0.8, intlat = 10, drawleg = TRUE, subsampleg = NULL, @@ -349,11 +354,18 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), } # Check brks2 - if (is.null(brks2)) { - if (!is.null(contours)) { + if (!is.null(contours)) { + if (is.null(brks2)) { 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) + brks2 <- unique(signif(seq(ll, ul, length.out = length(brks)), 2)) + + } else if (is.numeric(brks2) & length(brks2) == 1) { + ll <- signif(min(contours, na.rm = TRUE), 2) + ul <- signif(max(contours, na.rm = TRUE), 2) + brks2 <- unique(signif(seq(ll, ul, length.out = brks2), 2)) + } else if (!is.numeric(brks2)) { + stop("Parameter 'brks2' must be a numeric value or vector.") } } @@ -372,6 +384,11 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), stop("Parameter 'contour_lty' must be either a number or a character string.") } + # Check contour_label_draw + if (!is.logical(contour_label_draw)) { + stop("Parameter 'contour_label_draw' must be a logical value.") + } + # Check contour_label_scale if (!is.numeric(contour_label_scale)) { stop("Parameter 'contour_label_scale' must be numeric.") @@ -554,7 +571,7 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), if (!is.null(contours)) { nbrks2 <- length(brks2) for (n_brks2 in 1:nbrks2) { - cl <- grDevices::contourLines(x = lon, y = lat[which(lat >= latlims[1] & lat <= latlims[2])], + cl <- grDevices::contourLines(x = lon, y = lat[which(lat >= latlims[1] & lat <= latlims[2])], z = contours[, which(lat >= latlims[1] & lat <= latlims[2])], levels = brks2[n_brks2]) if (length(cl) > 0) { @@ -563,11 +580,47 @@ PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), xc <- xy$x yc <- xy$y nc <- length(xc) - lines(xc, yc, col = contour_color) #, lwd=lwd[n_brks2], lty=lty[n_brks2]) + lines(xc, yc, col = contour_color, lwd = contour_lwd, lty = contour_lty) # draw label - text(xc[1], yc[1], as.character(round(brks2[n_brks2], 2)), cex = contour_label_scale) -# text(xc[labelj], yc[labelj], label, col=col[n_brks2], srt=angle*180/pi, cex=labcex[n_brks2]) + if (contour_label_draw) { + label_char <- as.character(signif(brks2[n_brks2], 2)) + ## Check if the label has enough space to draw first. + last_slope <- Inf + put_label <- FALSE + for (p1 in 1:nc) { + p2 <- p1 + while (p2 < nc) { + dist <- sqrt((yc[p2] - yc[p1])^2 + (xc[p2] - xc[p1])^2) + if (!is.infinite(dist) & + dist > 1.2 * strwidth(label_char, cex = contour_label_scale)) { + put_label <- TRUE + slope <- (yc[p2] - yc[p1]) / (xc[p2] - xc[p1]) + # flatter is better + if (abs(slope) < abs(last_slope)) { + last_slope <- slope + last_p1 <- p1 + last_p2 <- p2 + } + break # Found a proper space for label. Move to the next p1. + } + p2 <- p2 + 1 # If the dist is not enough, try next p2. + } + } + + ## If label can be put + if (put_label) { + # Label should be at the middle of p1 and p2 + p_label <- (last_p1 + last_p2) / 2 + # string rotation angle is calculated from the slope + srt_label <- atan(last_slope) * 57.2958 # radian to degree + + #NOTE: 'cex' in text() is the scale factor. The actual size will be + # contour_label_scale * par("cex") + text(xc[p_label], yc[p_label], label_char, + cex = contour_label_scale, col = contour_color, srt = srt_label) + } + } } } } diff --git a/man/PlotStereoMap.Rd b/man/PlotStereoMap.Rd index 5393eec..cca91b4 100644 --- a/man/PlotStereoMap.Rd +++ b/man/PlotStereoMap.Rd @@ -28,6 +28,7 @@ PlotStereoMap( contour_lwd = 0.5, contour_color = "black", contour_lty = 1, + contour_label_draw = TRUE, contour_label_scale = 0.6, dots = NULL, dot_symbol = 4, @@ -126,18 +127,24 @@ continents. Takes the value 1 by default.} and displayed with contours. Parameter 'brks2' is required to define the magnitude breaks for each contour curve.} -\item{brks2}{Vector of magnitude breaks where to draw contour curves for the -array provided in 'contours'.} +\item{brks2}{A numeric value or vector of magnitude breaks where to draw +contour curves for the array provided in 'contours'. If it is a number, it +represents the number of breaks (n) that defines (n - 1) intervals to +classify 'contours'.} \item{contour_lwd}{Line width of the contour curves provided via 'contours' -and 'brks2'.} +and 'brks2'. The default value is 0.5.} -\item{contour_color}{Line color of the contour curves provided via 'contours' +\item{contour_color}{Line color of the contour curves provided via 'contours' and 'brks2'.} \item{contour_lty}{Line type of the contour curves. Takes 1 (solid) by default. See help on 'lty' in par() for other accepted values.} +\item{contour_label_draw}{A logical value indicating whether to draw the +contour labels (TRUE) or not (FALSE) when 'contours' is used. The default +value is TRUE.} + \item{contour_label_scale}{Scale factor for the superimposed labels when drawing contour levels. The default value is 0.6.} -- GitLab