From 1334128f9f9d056b9157d55b1dd72859c578b80b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Mon, 9 Mar 2020 15:16:35 +0100 Subject: [PATCH 1/8] the function has been added --- R/PlotTriangles4Categories.R | 274 +++++++++++++++++++++++++++++++++++ 1 file changed, 274 insertions(+) create mode 100644 R/PlotTriangles4Categories.R diff --git a/R/PlotTriangles4Categories.R b/R/PlotTriangles4Categories.R new file mode 100644 index 00000000..0ebf8f18 --- /dev/null +++ b/R/PlotTriangles4Categories.R @@ -0,0 +1,274 @@ +#'Function to convert any numerical array to a grid of coloured triangles. +#' +#'This function converts a numerical data array into a coloured +#'grid with triangles. It is useful for a slide or article to present tabular results as +#'colors instead of numbers. This can be used to compare the outputs of two or four categories (e.g. modes +#' of variability, clusters, or forecast systems). +#' +#'@param var an array with three dimensions: rows, columns and categories +#' containing the values to be displayed in a colored image with triangles. +#'@param poscols the dimension that will be represented as columns. +#'@param posrows the dimension that will be reprsented as rows. +#'@param brks A vector of the color bar intervals. The length must be one more +#' than the parameter 'cols'. Use ColorBar() to generate default values. +#'@param cols A vector of valid colour identifiers for color bar. The length +#' must be one less than the parameter 'brks'. Use ColorBar() to generate +#' default values. +#'@param toptitle A string of the title of the grid. Set NULL as default. +#'@param sig_var logical array with the same dimensions as 'var' to add layers +#' to the plot. A value of TRUE at a grid cell will draw a dot/symbol on the +#' corresponding triangle of the plot. Set NULL as default. +#'@param pch_sig symbol to be used to represent sig_var. Takes 18 +#' (diamond) by default. See 'pch' in par() for additional +#' accepted options. +#'@param col_sig colour of the symbol to represent sig_var. +#'@param cex_sig parameter to increase/reduce the size of the symbols used +#' to represent sig_var. +#'@param xlab A logical value (TRUE) indicating if xlabels should be plotted +#'@param ylab A logical value (TRUE) indicating if ylabels should be plotted +#'@param xlabels A vector of labels of the x-axis The length must be +#' length of the col of parameter 'var'. Set the sequence from 1 to the +#' length of the row of parameter 'var' as default. +#'@param xtitle A string of title of the x-axis. Set NULL as default. +#'@param ylabels A vector of labels of the y-axis The length must be +#' length of the row of parameter 'var'. Set the sequence from 1 to the +#' length of the row of parameter 'var' as default. +#'@param ytitle A string of title of the y-axis. Set NULL as default. +#'@param legend A logical value to decide to draw the color bar legend or not. +#' Set TRUE as default. +#'@param lab_legend A vector of labels indicating what is represented in each +#'category (i.e. triangle). Set the sequence from 1 to the length of +#' the categories (2 or 4). +#'@param cex_leg a number to indicate the increase/reductuion of the lab_legend used +#' to represent sig_var. +#'@param col_leg color of the legend (triangles). +#'@param fileout A string of full directory path and file name indicating where +#' to save the plot. If not specified (default), a graphics device will pop up. +#'@param size_units A string indicating the units of the size of the device +#' (file or window) to plot in. Set 'px' as default. See ?Devices and the +#' creator function of the corresponding device. +#'@param res A positive number indicating resolution of the device (file or window) +#' to plot in. See ?Devices and the creator function of the corresponding device. +#'@param ... The additional parameters to be passed to function ColorBar() in +#' s2dverification for color legend creation. +#'@return A figure in popup window by default, or saved to the specified path. +#' +#'@author History:\cr +#'1.0 - 2019-10 (V.Torralba, \email{veronica.torralba@bsc.es}) - Original code +#' +#'@examples +#'#Example with random data +#' arr1<- arr1<- array(runif(n = 12 * 7 * 4, min=-1, max=1),dim = c(12,7,4)) +#'arr2<- array(TRUE,dim = dim(arr1)) +#'arr2[which(arr1 < 0.3)] = FALSE +#'PlotTriangles4Categories(var = arr1, +#' cols = c('white','#fef0d9','#fdd49e','#fdbb84','#fc8d59', +#' '#e34a33','#b30000', '#7f0000'), +#' brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), +#' xtitle = "Target month", ytitle = "Lead time", +#' xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", +#' "Aug", "Sep", "Oct", "Nov", "Dec")) +#'@importFrom grDevices dev.new dev.off dev.cur +#'@export + +PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, + toptitle=NULL, + sig_var=NULL,col_sig='black',pch_sig=18, + cex_sig=1, + labx=TRUE, + laby=TRUE, + xlabels=NULL, xtitle=NULL, + ylabels=NULL, ytitle=NULL, + legend=TRUE,lab_legend=NULL, + cex_leg=1,col_leg='black', + fileout=NULL, + size_units = 'px', res = 100, + figure.width = 1, + ...){ + # Checking the dimensions + vardim<-dim(var) + nrow<-vardim[posrows] + ncol<-vardim[poscols] + poscat<-vardim[setdiff(1:length(vardim),c(posrows,poscols))] + + # If there is any filenames to store the graphics, process them + # to select the right device + if (!is.null(fileout)) { + deviceInfo <- s2dverification:::.SelectDevice(fileout = fileout, + width = 80 * ncol * figure.width, + height = 80 * nrow, + units = size_units, res = res) + saveToFile <- deviceInfo$fun + fileout <- deviceInfo$files + } + + # 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 = 8 * figure.width, height = 5) + } + + if (!is.null(sig_var)){ + if (!is.logical(sig_var)){ + stop('sig_var array should be provided as TRUE/FALSE') + } + if (all(dim(sig_var)!=dim(var))){ + stop('sig_var array should have the same dimensions that var') + } + } + + if (length(vardim)!=3){ + stop('var must be an array with three dimensions (4, cols, rows) ') + } + + if (poscat!=4 && poscat!=2){ + stop('var must be an array with one of the dimensions being equal to 4 or 2') + } + + # The dimensions are named + names(dim(var))[poscols]<-'cols' + names(dim(var))[posrows]<-'rows' + names(dim(var))[setdiff(1:length(vardim),c(posrows,poscols))]<-'cat' + + if (!is.null(sig_var)){ + names(dim(sig_var))<-names(dim(var)) + } + + # Checking what is available and generating missing information + if (!is.null(lab_legend)&&length(lab_legend)!=4){ + stop('The legend should contain 4 names') + } + + if (is.null(xlabels)){ + xlabels=1:ncol + } + if (is.null(ylabels)){ + ylabels=1:nrow + } + if (is.null(brks)){ + brks<-seq(min(var),max(var),length.out = 9) + } + if (is.null(cols)){ + cols<-rev(brewer.pal(length(brks)-1,'RdBu')) + } + + # The colours for each triangle/category are defined + var_cat <- array(cols[length(cols)], dim = vardim) + names(dim(var_cat)) <- names(dim(var)) + for (i in (length(cols) - 1):1) { + var_cat[var < brks[i + 1]] <- cols[i] + } + + if(legend){ + # layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,2),heights=c(10,2)) + # par(oma=c(1,1,1,1),mar=c(5,4,4,0)) + layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,1.3),heights=c(10,3.5)) + par(oma=c(1,1,1,1),mar=c(5,12,0,0)) + if(is.null(lab_legend)){ + lab_legend=1:4 + } + } + + plot(ncol,nrow,xlim = c(0,ncol),ylim=c(0,nrow), xaxs="i",yaxs='i',type="n", + xaxt="n", yaxt="n",ann=F,axes=F) + + box(col='black',lwd=1) + + if (! is.null(toptitle)){ + title(toptitle, cex=1.5) + } + + if (!is.null(xtitle)){ + mtext(side = 1, text = xtitle, line = 4, cex=1.5) + } + if (!is.null(ytitle)){ + mtext(side = 2, text = ytitle, line = 2.5, cex=1.5) + } + + if (labx){ + axis(1, at=(1:ncol)-0.5, las=2, labels=xlabels, cex.axis=1.5) + } + if (laby){ + axis(2, at=(1:nrow)-0.5, las=2, labels=ylabels, cex.axis=1.5) + } + + + #The triangles are plotted + for(p in 1:ncol){ + for(l in 1:nrow){ + if (poscat==4){ + coord_triangl <- list(xs=list(c(p-1, p-0.5, p-1),c(p-1, p-0.5, p),c(p, p-0.5, p),c(p-1, p-0.5, p)), + ys=list( c(l-1, -0.5+l, l), c(l-1, -0.5+l, l-1),c(l-1, -0.5+l, l),c(l, -0.5+l, l))) + + coord_sig <- list(x=c(p-0.75,p-0.5,p-0.25,p-0.5),y=c(l-0.5,l-0.75,l-0.5,l-0.25)) + } + + if (poscat==2){ +# coord_triangl<- list(xs=list(c(p-1, p, p),c(p-1, p, p-1)), +# ys=list( c(l-1,l-1, l), c(l-1, l, l))) + coord_triangl<- list(xs=list(c(p-1, p, p-1),c(p-1, p, p)), + ys=list(c(l-1, l, l),c(l-1,l-1, l))) + coord_sig<- list(x=c(p-(2/3),p-(1/3)),y=c(l-(1/3),l-(2/3))) + } + for (n in 1:poscat) { + polygon(coord_triangl$xs[[n]], + coord_triangl$ys[[n]], + col = Subset( + var_cat, + along = c('cat', 'cols', 'rows'), + indices = list(n, p, l))) + if (!is.null(sig_var) && + Subset(sig_var,along = c('cat', 'cols', 'rows'), + indices = list(n, p, l))) { + points( + x = coord_sig$x[n], + y = coord_sig$y[n], + pch = pch_sig, + cex = cex_sig, + col = col_sig + ) + } + } + } + } + + # legend + + if(legend){ + # Colorbar + par(mar=c(0,0,0,0)) + ColorBar(brks = brks, cols = cols, vert=T,draw_ticks = T, draw_separators = T, + # extra_margin = c(0,0,2.5,0),label_scale = 1.5,...) + extra_margin = c(0,0,0,0),label_scale = 1.5,...) + + par(mar=c(0.5,2.5,0,2.5)) + plot(1,1,xlim = c(0,1),ylim=c(0,1), xaxs="i",yaxs='i',type="n", + xaxt="n", yaxt="n",ann=F,axes=F) + + box(col=col_leg) + p=l=1 + if (poscat==4){ + coord_triangl <- list(xs=list(c(p-1, p-0.5, p-1),c(p-1, p-0.5, p),c(p, p-0.5, p),c(p-1, p-0.5, p)), + ys=list( c(l-1, -0.5+l, l), c(l-1, -0.5+l, l-1),c(l-1, -0.5+l, l),c(l, -0.5+l, l))) + + coord_sig <- list(x=c(p-0.75,p-0.5,p-0.25,p-0.5),y=c(l-0.5,l-0.75,l-0.5,l-0.25)) + } + + if (poscat==2){ + coord_triangl<- list(xs=list(c(p-1, p, p),c(p-1, p, p-1)), + ys=list( c(l-1,l-1, l), c(l-1, l, l))) + coord_sig<- list(x=c(p-(2/3),p-(1/3)),y=c(l-(1/3),l-(2/3))) + } + for (n in 1:poscat) { + polygon(coord_triangl$xs[[n]], + coord_triangl$ys[[n]],border=col_leg) + text(x=coord_sig$x[[n]],y=coord_sig$y[[n]],labels = lab_legend[n],cex=cex_leg,col=col_leg) + + } + } + + # If the graphic was saved to file, close the connection with the device + if (!is.null(fileout)) dev.off() +} -- GitLab From a18f70f18774090aa0fb29803219884be4744010 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Mon, 9 Mar 2020 19:26:08 +0100 Subject: [PATCH 2/8] adding some Nuria suggestions --- R/PlotTriangles4Categories.R | 119 ++++++++++++++++------------------- 1 file changed, 55 insertions(+), 64 deletions(-) diff --git a/R/PlotTriangles4Categories.R b/R/PlotTriangles4Categories.R index 0ebf8f18..df5c1cdf 100644 --- a/R/PlotTriangles4Categories.R +++ b/R/PlotTriangles4Categories.R @@ -1,38 +1,36 @@ -#'Function to convert any numerical array to a grid of coloured triangles. +#'Function to convert any 3-d numerical array to a grid of coloured triangles. #' -#'This function converts a numerical data array into a coloured +#'This function converts a 3-d numerical data array into a coloured #'grid with triangles. It is useful for a slide or article to present tabular results as -#'colors instead of numbers. This can be used to compare the outputs of two or four categories (e.g. modes -#' of variability, clusters, or forecast systems). +#'colors instead of numbers. This can be used to compare the outputs of two or four categories ( +#'e.g. modes of variability, clusters, or forecast systems). #' -#'@param var an array with three dimensions: rows, columns and categories -#' containing the values to be displayed in a colored image with triangles. -#'@param poscols the dimension that will be represented as columns. -#'@param posrows the dimension that will be reprsented as rows. +#'@param data array with three named dimensions: 'dimx', 'dimy', 'dimcat', +#' containing the values to be displayed in a coloured image with triangles. #'@param brks A vector of the color bar intervals. The length must be one more #' than the parameter 'cols'. Use ColorBar() to generate default values. #'@param cols A vector of valid colour identifiers for color bar. The length #' must be one less than the parameter 'brks'. Use ColorBar() to generate #' default values. #'@param toptitle A string of the title of the grid. Set NULL as default. -#'@param sig_var logical array with the same dimensions as 'var' to add layers +#'@param sig_data logical array with the same dimensions as 'data' to add layers #' to the plot. A value of TRUE at a grid cell will draw a dot/symbol on the #' corresponding triangle of the plot. Set NULL as default. -#'@param pch_sig symbol to be used to represent sig_var. Takes 18 +#'@param pch_sig symbol to be used to represent sig_data. Takes 18 #' (diamond) by default. See 'pch' in par() for additional #' accepted options. -#'@param col_sig colour of the symbol to represent sig_var. +#'@param col_sig colour of the symbol to represent sig_data. #'@param cex_sig parameter to increase/reduce the size of the symbols used -#' to represent sig_var. +#' to represent sig_data. #'@param xlab A logical value (TRUE) indicating if xlabels should be plotted #'@param ylab A logical value (TRUE) indicating if ylabels should be plotted #'@param xlabels A vector of labels of the x-axis The length must be -#' length of the col of parameter 'var'. Set the sequence from 1 to the -#' length of the row of parameter 'var' as default. +#' length of the col of parameter 'data'. Set the sequence from 1 to the +#' length of the row of parameter 'data' as default. #'@param xtitle A string of title of the x-axis. Set NULL as default. #'@param ylabels A vector of labels of the y-axis The length must be -#' length of the row of parameter 'var'. Set the sequence from 1 to the -#' length of the row of parameter 'var' as default. +#' length of the row of parameter 'data'. Set the sequence from 1 to the +#' length of the row of parameter 'data' as default. #'@param ytitle A string of title of the y-axis. Set NULL as default. #'@param legend A logical value to decide to draw the color bar legend or not. #' Set TRUE as default. @@ -40,7 +38,7 @@ #'category (i.e. triangle). Set the sequence from 1 to the length of #' the categories (2 or 4). #'@param cex_leg a number to indicate the increase/reductuion of the lab_legend used -#' to represent sig_var. +#' to represent sig_data. #'@param col_leg color of the legend (triangles). #'@param fileout A string of full directory path and file name indicating where #' to save the plot. If not specified (default), a graphics device will pop up. @@ -54,14 +52,15 @@ #'@return A figure in popup window by default, or saved to the specified path. #' #'@author History:\cr -#'1.0 - 2019-10 (V.Torralba, \email{veronica.torralba@bsc.es}) - Original code +#'1.0 - 2020-10 (V.Torralba, \email{veronica.torralba@bsc.es}) - Original code #' #'@examples #'#Example with random data #' arr1<- arr1<- array(runif(n = 12 * 7 * 4, min=-1, max=1),dim = c(12,7,4)) +#' names(dim(arr1)) <- c('dimx','dimy','dimcat') #'arr2<- array(TRUE,dim = dim(arr1)) #'arr2[which(arr1 < 0.3)] = FALSE -#'PlotTriangles4Categories(var = arr1, +#'PlotTriangles4Categories(data = arr1, #' cols = c('white','#fef0d9','#fdd49e','#fdbb84','#fc8d59', #' '#e34a33','#b30000', '#7f0000'), #' brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), @@ -71,9 +70,9 @@ #'@importFrom grDevices dev.new dev.off dev.cur #'@export -PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, +PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, toptitle=NULL, - sig_var=NULL,col_sig='black',pch_sig=18, + sig_data=NULL,col_sig='black',pch_sig=18, cex_sig=1, labx=TRUE, laby=TRUE, @@ -86,10 +85,10 @@ PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, figure.width = 1, ...){ # Checking the dimensions - vardim<-dim(var) - nrow<-vardim[posrows] - ncol<-vardim[poscols] - poscat<-vardim[setdiff(1:length(vardim),c(posrows,poscols))] + datadim <- dim(data) + nrow <- dim(data)['dimy'] + ncol <- dim(data)['dimx'] + ncat <- dim(data)['dimcat'] # If there is any filenames to store the graphics, process them # to select the right device @@ -107,33 +106,29 @@ PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, saveToFile(fileout) } else if (names(dev.cur()) == 'null device') { dev.new(units = size_units, res = res, - width = 8 * figure.width, height = 5) + width = 8 * figure.width, height =5) } - if (!is.null(sig_var)){ - if (!is.logical(sig_var)){ - stop('sig_var array should be provided as TRUE/FALSE') + if (!is.null(sig_data)){ + if (!is.logical(sig_data)){ + stop('sig_data array should be provided as TRUE/FALSE') } - if (all(dim(sig_var)!=dim(var))){ - stop('sig_var array should have the same dimensions that var') + if (all(dim(sig_data)!=dim(data))){ + stop('sig_data array should have the same dimensions that data') } } - if (length(vardim)!=3){ - stop('var must be an array with three dimensions (4, cols, rows) ') + if (length(datadim)!=3){ + stop('data must be an array with three dimensions ( e.g. 4, cols, rows) ') } - if (poscat!=4 && poscat!=2){ - stop('var must be an array with one of the dimensions being equal to 4 or 2') + if (ncat!=4 && ncat!=2){ + stop('data must be an array with dimcat being equal to + 4 or 2 (i.e only two or four categories can be plotted)') } - # The dimensions are named - names(dim(var))[poscols]<-'cols' - names(dim(var))[posrows]<-'rows' - names(dim(var))[setdiff(1:length(vardim),c(posrows,poscols))]<-'cat' - - if (!is.null(sig_var)){ - names(dim(sig_var))<-names(dim(var)) + if (!is.null(sig_data)){ + names(dim(sig_data))<-names(dim(data)) } # Checking what is available and generating missing information @@ -148,26 +143,24 @@ PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, ylabels=1:nrow } if (is.null(brks)){ - brks<-seq(min(var),max(var),length.out = 9) + brks<-seq(min(data),max(data),length.out = 9) } if (is.null(cols)){ cols<-rev(brewer.pal(length(brks)-1,'RdBu')) } # The colours for each triangle/category are defined - var_cat <- array(cols[length(cols)], dim = vardim) - names(dim(var_cat)) <- names(dim(var)) + data_cat <- array(cols[length(cols)], dim = datadim) + names(dim(data_cat)) <- names(dim(data)) for (i in (length(cols) - 1):1) { - var_cat[var < brks[i + 1]] <- cols[i] + data_cat[data < brks[i + 1]] <- cols[i] } if(legend){ - # layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,2),heights=c(10,2)) - # par(oma=c(1,1,1,1),mar=c(5,4,4,0)) - layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,1.3),heights=c(10,3.5)) - par(oma=c(1,1,1,1),mar=c(5,12,0,0)) + layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,3.4),heights=c(10,3.5)) + par(oma=c(1,1,1,1),mar=c(5,4,0,0)) if(is.null(lab_legend)){ - lab_legend=1:4 + lab_legend=1:ncat } } @@ -198,29 +191,27 @@ PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, #The triangles are plotted for(p in 1:ncol){ for(l in 1:nrow){ - if (poscat==4){ + if (ncat==4){ coord_triangl <- list(xs=list(c(p-1, p-0.5, p-1),c(p-1, p-0.5, p),c(p, p-0.5, p),c(p-1, p-0.5, p)), ys=list( c(l-1, -0.5+l, l), c(l-1, -0.5+l, l-1),c(l-1, -0.5+l, l),c(l, -0.5+l, l))) coord_sig <- list(x=c(p-0.75,p-0.5,p-0.25,p-0.5),y=c(l-0.5,l-0.75,l-0.5,l-0.25)) } - if (poscat==2){ -# coord_triangl<- list(xs=list(c(p-1, p, p),c(p-1, p, p-1)), -# ys=list( c(l-1,l-1, l), c(l-1, l, l))) + if (ncat==2){ coord_triangl<- list(xs=list(c(p-1, p, p-1),c(p-1, p, p)), ys=list(c(l-1, l, l),c(l-1,l-1, l))) coord_sig<- list(x=c(p-(2/3),p-(1/3)),y=c(l-(1/3),l-(2/3))) } - for (n in 1:poscat) { + for (n in 1:ncat) { polygon(coord_triangl$xs[[n]], coord_triangl$ys[[n]], col = Subset( - var_cat, - along = c('cat', 'cols', 'rows'), + data_cat, + along = c('dimcat', 'dimx', 'dimy'), indices = list(n, p, l))) - if (!is.null(sig_var) && - Subset(sig_var,along = c('cat', 'cols', 'rows'), + if (!is.null(sig_data) && + Subset(sig_data,along = c('dimcat', 'dimx', 'dimy'), indices = list(n, p, l))) { points( x = coord_sig$x[n], @@ -243,25 +234,25 @@ PlotTriangles4Categories<-function(var,poscols=1,posrows=2,cols=NULL,brks=NULL, # extra_margin = c(0,0,2.5,0),label_scale = 1.5,...) extra_margin = c(0,0,0,0),label_scale = 1.5,...) - par(mar=c(0.5,2.5,0,2.5)) + par(mar=c(0.5,2.5,0.5,2.5)) plot(1,1,xlim = c(0,1),ylim=c(0,1), xaxs="i",yaxs='i',type="n", xaxt="n", yaxt="n",ann=F,axes=F) box(col=col_leg) p=l=1 - if (poscat==4){ + if (ncat==4){ coord_triangl <- list(xs=list(c(p-1, p-0.5, p-1),c(p-1, p-0.5, p),c(p, p-0.5, p),c(p-1, p-0.5, p)), ys=list( c(l-1, -0.5+l, l), c(l-1, -0.5+l, l-1),c(l-1, -0.5+l, l),c(l, -0.5+l, l))) coord_sig <- list(x=c(p-0.75,p-0.5,p-0.25,p-0.5),y=c(l-0.5,l-0.75,l-0.5,l-0.25)) } - if (poscat==2){ + if (ncat==2){ coord_triangl<- list(xs=list(c(p-1, p, p),c(p-1, p, p-1)), ys=list( c(l-1,l-1, l), c(l-1, l, l))) coord_sig<- list(x=c(p-(2/3),p-(1/3)),y=c(l-(1/3),l-(2/3))) } - for (n in 1:poscat) { + for (n in 1:ncat) { polygon(coord_triangl$xs[[n]], coord_triangl$ys[[n]],border=col_leg) text(x=coord_sig$x[[n]],y=coord_sig$y[[n]],labels = lab_legend[n],cex=cex_leg,col=col_leg) -- GitLab From fa8388ac76d7c422b8ef60a83dc887de6275ea98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Mon, 9 Mar 2020 19:33:45 +0100 Subject: [PATCH 3/8] adding some checks --- R/PlotTriangles4Categories.R | 43 +++++++++++++++++++++--------------- 1 file changed, 25 insertions(+), 18 deletions(-) diff --git a/R/PlotTriangles4Categories.R b/R/PlotTriangles4Categories.R index df5c1cdf..b69aa93d 100644 --- a/R/PlotTriangles4Categories.R +++ b/R/PlotTriangles4Categories.R @@ -85,6 +85,30 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, figure.width = 1, ...){ # Checking the dimensions + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must be an array with named dimensions") + } + + if (length(dim(data))!=3) { + stop("Parameter 'data' must be an array with three dimensions") + } + + if (!is.null(sig_data)) { + if (!is.logical(sig_data)) { + stop("Parameter 'sig_data array must be logical (i.e TRUE/FALSE) ") + } + if (names(dim(sig_data)) != names(dim(data))) { + stop("Parameter 'sig_data' must be an array with the same named dimensions as data") + } + } + + if (dim(data)['dimcat'] != 4 && dim(data)['dimcat'] != 2) { + stop( + "Parameter 'data' should contain a dimcat dimension with length equal + to two or four as only two or four categories can be plotted") + } + + datadim <- dim(data) nrow <- dim(data)['dimy'] ncol <- dim(data)['dimx'] @@ -108,24 +132,7 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, dev.new(units = size_units, res = res, width = 8 * figure.width, height =5) } - - if (!is.null(sig_data)){ - if (!is.logical(sig_data)){ - stop('sig_data array should be provided as TRUE/FALSE') - } - if (all(dim(sig_data)!=dim(data))){ - stop('sig_data array should have the same dimensions that data') - } - } - - if (length(datadim)!=3){ - stop('data must be an array with three dimensions ( e.g. 4, cols, rows) ') - } - - if (ncat!=4 && ncat!=2){ - stop('data must be an array with dimcat being equal to - 4 or 2 (i.e only two or four categories can be plotted)') - } + if (!is.null(sig_data)){ names(dim(sig_data))<-names(dim(data)) -- GitLab From f8430063ffc6c2d854a89a26f7d47692918917aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Fri, 3 Apr 2020 16:32:09 +0200 Subject: [PATCH 4/8] small changes in the checks and tests --- R/PlotTriangles4Categories.R | 82 +++++++++++++++++++++--------------- 1 file changed, 48 insertions(+), 34 deletions(-) diff --git a/R/PlotTriangles4Categories.R b/R/PlotTriangles4Categories.R index b69aa93d..11dc513d 100644 --- a/R/PlotTriangles4Categories.R +++ b/R/PlotTriangles4Categories.R @@ -71,43 +71,60 @@ #'@export PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, - toptitle=NULL, - sig_data=NULL,col_sig='black',pch_sig=18, - cex_sig=1, - labx=TRUE, - laby=TRUE, - xlabels=NULL, xtitle=NULL, - ylabels=NULL, ytitle=NULL, - legend=TRUE,lab_legend=NULL, - cex_leg=1,col_leg='black', - fileout=NULL, - size_units = 'px', res = 100, - figure.width = 1, - ...){ + toptitle=NULL, + sig_data=NULL,col_sig='black',pch_sig=18, + cex_sig=1, + labx=TRUE, + laby=TRUE, + xlabels=NULL, xtitle=NULL, + ylabels=NULL, ytitle=NULL, + legend=TRUE,lab_legend=NULL, + cex_leg=1,col_leg='black', + fileout=NULL, + size_units = 'px', res = 100, + figure.width = 1, + ...){ # Checking the dimensions - if (is.null(names(dim(data)))) { - stop("Parameter 'data' must be an array with named dimensions") + if (length(dim(data))!=3) { + stop("Parameter 'data' must be an array with three dimensions.") } - if (length(dim(data))!=3) { - stop("Parameter 'data' must be an array with three dimensions") + if (any(is.na(data))){ + stop("Parameter 'data' cannot contain NAs.") + } + + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must be an array with named dimensions.") + }else{ + if (!any(names(dim(data))=='dimx')|!any(names(dim(data))=='dimy')|!any(names(dim(data))=='dimcat')){ + stop("Parameter 'data' should contain 'dimx', 'dimy' and 'dimcat' dimension names. ") + } } if (!is.null(sig_data)) { if (!is.logical(sig_data)) { - stop("Parameter 'sig_data array must be logical (i.e TRUE/FALSE) ") - } - if (names(dim(sig_data)) != names(dim(data))) { - stop("Parameter 'sig_data' must be an array with the same named dimensions as data") + stop("Parameter 'sig_data' array must be logical.")} + else if (length(dim(sig_data)) !=3) { + stop("Parameter 'sig_data' must be an array with three dimensions.") + }else if (any(dim(sig_data) != dim(data))){ + stop("Parameter 'sig_data' must be an array with the same dimensions as 'data'.") + }else if(!is.null(names(dim(sig_data)))){ + if (any(names(dim(sig_data)) != names(dim(data)))){ + stop("Parameter 'sig_data' must be an array with the same named dimensions as 'data'.")} } } - + if (dim(data)['dimcat'] != 4 && dim(data)['dimcat'] != 2) { stop( - "Parameter 'data' should contain a dimcat dimension with length equal - to two or four as only two or four categories can be plotted") + "Parameter 'data' should contain a dimcat dimension with length equals + to two or four as only two or four categories can be plotted.") + } + + # Checking what is available and generating missing information + if (!is.null(lab_legend) && + length(lab_legend) != 4 && length(lab_legend) != 2){ + stop("Parameter 'lab_legend' should contain two or four names.") } - datadim <- dim(data) nrow <- dim(data)['dimy'] @@ -132,16 +149,13 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, dev.new(units = size_units, res = res, width = 8 * figure.width, height =5) } - + if (!is.null(sig_data)){ names(dim(sig_data))<-names(dim(data)) } - # Checking what is available and generating missing information - if (!is.null(lab_legend)&&length(lab_legend)!=4){ - stop('The legend should contain 4 names') - } + if (is.null(xlabels)){ xlabels=1:ncol @@ -150,7 +164,7 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, ylabels=1:nrow } if (is.null(brks)){ - brks<-seq(min(data),max(data),length.out = 9) + brks <- seq(min(data, na.rm=T), max(data, na.rm=T),length.out = 9) } if (is.null(cols)){ cols<-rev(brewer.pal(length(brks)-1,'RdBu')) @@ -164,7 +178,7 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, } if(legend){ - layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,3.4),heights=c(10,3.5)) + layout(matrix(c(1,2,1,3),2,2,byrow=T),widths =c(10,3.4),heights=c(10,3.5)) par(oma=c(1,1,1,1),mar=c(5,4,0,0)) if(is.null(lab_legend)){ lab_legend=1:ncat @@ -206,9 +220,9 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, } if (ncat==2){ - coord_triangl<- list(xs=list(c(p-1, p, p-1),c(p-1, p, p)), + coord_triangl <- list(xs=list(c(p-1, p, p-1),c(p-1, p, p)), ys=list(c(l-1, l, l),c(l-1,l-1, l))) - coord_sig<- list(x=c(p-(2/3),p-(1/3)),y=c(l-(1/3),l-(2/3))) + coord_sig <- list(x=c(p-(2/3),p-(1/3)),y=c(l-(1/3),l-(2/3))) } for (n in 1:ncat) { polygon(coord_triangl$xs[[n]], -- GitLab From 5e551a79e07a848206398dcb753d32bb58e5103c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Thu, 28 May 2020 13:25:12 +0200 Subject: [PATCH 5/8] generating documentation --- NAMESPACE | 1 + man/PlotTriangles4Categories.Rd | 126 ++++++++++++++++++++++++++++++++ 2 files changed, 127 insertions(+) create mode 100644 man/PlotTriangles4Categories.Rd diff --git a/NAMESPACE b/NAMESPACE index bd5d0f16..48553a59 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,6 +27,7 @@ export(MultiEOF) export(PlotCombinedMap) export(PlotForecastPDF) export(PlotMostLikelyQuantileMap) +export(PlotTriangles4Categories) export(RFSlope) export(RainFARM) export(SplitDim) diff --git a/man/PlotTriangles4Categories.Rd b/man/PlotTriangles4Categories.Rd new file mode 100644 index 00000000..d47103b7 --- /dev/null +++ b/man/PlotTriangles4Categories.Rd @@ -0,0 +1,126 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotTriangles4Categories.R +\name{PlotTriangles4Categories} +\alias{PlotTriangles4Categories} +\title{Function to convert any 3-d numerical array to a grid of coloured triangles.} +\usage{ +PlotTriangles4Categories( + data, + cols = NULL, + brks = NULL, + toptitle = NULL, + sig_data = NULL, + col_sig = "black", + pch_sig = 18, + cex_sig = 1, + labx = TRUE, + laby = TRUE, + xlabels = NULL, + xtitle = NULL, + ylabels = NULL, + ytitle = NULL, + legend = TRUE, + lab_legend = NULL, + cex_leg = 1, + col_leg = "black", + fileout = NULL, + size_units = "px", + res = 100, + figure.width = 1, + ... +) +} +\arguments{ +\item{data}{array with three named dimensions: 'dimx', 'dimy', 'dimcat', +containing the values to be displayed in a coloured image with triangles.} + +\item{cols}{A vector of valid colour identifiers for color bar. The length +must be one less than the parameter 'brks'. Use ColorBar() to generate +default values.} + +\item{brks}{A vector of the color bar intervals. The length must be one more +than the parameter 'cols'. Use ColorBar() to generate default values.} + +\item{toptitle}{A string of the title of the grid. Set NULL as default.} + +\item{sig_data}{logical array with the same dimensions as 'data' to add layers +to the plot. A value of TRUE at a grid cell will draw a dot/symbol on the +corresponding triangle of the plot. Set NULL as default.} + +\item{col_sig}{colour of the symbol to represent sig_data.} + +\item{pch_sig}{symbol to be used to represent sig_data. Takes 18 +(diamond) by default. See 'pch' in par() for additional +accepted options.} + +\item{cex_sig}{parameter to increase/reduce the size of the symbols used +to represent sig_data.} + +\item{xlabels}{A vector of labels of the x-axis The length must be +length of the col of parameter 'data'. Set the sequence from 1 to the +length of the row of parameter 'data' as default.} + +\item{xtitle}{A string of title of the x-axis. Set NULL as default.} + +\item{ylabels}{A vector of labels of the y-axis The length must be +length of the row of parameter 'data'. Set the sequence from 1 to the +length of the row of parameter 'data' as default.} + +\item{ytitle}{A string of title of the y-axis. Set NULL as default.} + +\item{legend}{A logical value to decide to draw the color bar legend or not. +Set TRUE as default.} + +\item{lab_legend}{A vector of labels indicating what is represented in each +category (i.e. triangle). Set the sequence from 1 to the length of +the categories (2 or 4).} + +\item{cex_leg}{a number to indicate the increase/reductuion of the lab_legend used +to represent sig_data.} + +\item{col_leg}{color of the legend (triangles).} + +\item{fileout}{A string of full directory path and file name indicating where +to save the plot. If not specified (default), a graphics device will pop up.} + +\item{size_units}{A string indicating the units of the size of the device +(file or window) to plot in. Set 'px' as default. See ?Devices and the +creator function of the corresponding device.} + +\item{res}{A positive number indicating resolution of the device (file or window) +to plot in. See ?Devices and the creator function of the corresponding device.} + +\item{...}{The additional parameters to be passed to function ColorBar() in +s2dverification for color legend creation.} + +\item{xlab}{A logical value (TRUE) indicating if xlabels should be plotted} + +\item{ylab}{A logical value (TRUE) indicating if ylabels should be plotted} +} +\value{ +A figure in popup window by default, or saved to the specified path. +} +\description{ +This function converts a 3-d numerical data array into a coloured +grid with triangles. It is useful for a slide or article to present tabular results as +colors instead of numbers. This can be used to compare the outputs of two or four categories ( +e.g. modes of variability, clusters, or forecast systems). +} +\examples{ +#Example with random data +arr1<- arr1<- array(runif(n = 12 * 7 * 4, min=-1, max=1),dim = c(12,7,4)) +names(dim(arr1)) <- c('dimx','dimy','dimcat') +arr2<- array(TRUE,dim = dim(arr1)) +arr2[which(arr1 < 0.3)] = FALSE +PlotTriangles4Categories(data = arr1, + cols = c('white','#fef0d9','#fdd49e','#fdbb84','#fc8d59', + '#e34a33','#b30000', '#7f0000'), + brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), + xtitle = "Target month", ytitle = "Lead time", + xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + "Aug", "Sep", "Oct", "Nov", "Dec")) +} +\author{ +History:\cr +1.0 - 2020-10 (V.Torralba, \email{veronica.torralba@bsc.es}) - Original code +} -- GitLab From 18bef98f12bee96cbdef6bbaa503a863346a35d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Fri, 29 May 2020 10:26:33 +0200 Subject: [PATCH 6/8] changes suggested by Eida --- R/PlotTriangles4Categories.R | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/R/PlotTriangles4Categories.R b/R/PlotTriangles4Categories.R index 11dc513d..bf83960e 100644 --- a/R/PlotTriangles4Categories.R +++ b/R/PlotTriangles4Categories.R @@ -150,19 +150,18 @@ PlotTriangles4Categories <- function(data,cols=NULL,brks=NULL, width = 8 * figure.width, height =5) } - - if (!is.null(sig_data)){ - names(dim(sig_data))<-names(dim(data)) - } - - - if (is.null(xlabels)){ xlabels=1:ncol } if (is.null(ylabels)){ ylabels=1:nrow } + + if (!is.null(brks) && !is.null(cols)){ + if (length(brks) != length(cols)+1){ + stop("The length of the parameter 'brks' must be one more than 'cols'.") + } + } if (is.null(brks)){ brks <- seq(min(data, na.rm=T), max(data, na.rm=T),length.out = 9) } -- GitLab From 7eba638df6eba1ab3bb19efe7ddb0ac4ea9d31cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ver=C3=B3nica=20Torralba-Fern=C3=A1ndez?= Date: Fri, 29 May 2020 11:36:44 +0200 Subject: [PATCH 7/8] changes in the tests and examples --- R/PlotTriangles4Categories.R | 5 +- man/PlotTriangles4Categories.Rd | 5 +- .../testthat/test-PlotTriangles4Categories.R | 65 +++++++++++++++++++ 3 files changed, 71 insertions(+), 4 deletions(-) create mode 100644 tests/testthat/test-PlotTriangles4Categories.R diff --git a/R/PlotTriangles4Categories.R b/R/PlotTriangles4Categories.R index bf83960e..cda320f9 100644 --- a/R/PlotTriangles4Categories.R +++ b/R/PlotTriangles4Categories.R @@ -63,9 +63,10 @@ #'PlotTriangles4Categories(data = arr1, #' cols = c('white','#fef0d9','#fdd49e','#fdbb84','#fc8d59', #' '#e34a33','#b30000', '#7f0000'), -#' brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), +#' brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), +#' lab_legend = c('NAO+', 'BL','AR','NAO-'), #' xtitle = "Target month", ytitle = "Lead time", -#' xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", +#' xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", #' "Aug", "Sep", "Oct", "Nov", "Dec")) #'@importFrom grDevices dev.new dev.off dev.cur #'@export diff --git a/man/PlotTriangles4Categories.Rd b/man/PlotTriangles4Categories.Rd index d47103b7..14ab5114 100644 --- a/man/PlotTriangles4Categories.Rd +++ b/man/PlotTriangles4Categories.Rd @@ -115,9 +115,10 @@ arr2[which(arr1 < 0.3)] = FALSE PlotTriangles4Categories(data = arr1, cols = c('white','#fef0d9','#fdd49e','#fdbb84','#fc8d59', '#e34a33','#b30000', '#7f0000'), - brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), + brks = c(-1, 0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 1), + lab_legend = c('NAO+', 'BL','AR','NAO-'), xtitle = "Target month", ytitle = "Lead time", - xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")) } \author{ diff --git a/tests/testthat/test-PlotTriangles4Categories.R b/tests/testthat/test-PlotTriangles4Categories.R new file mode 100644 index 00000000..8105cc91 --- /dev/null +++ b/tests/testthat/test-PlotTriangles4Categories.R @@ -0,0 +1,65 @@ +context("Generic tests") +test_that("Sanity checks", { + expect_error( + PlotTriangles4Categories(data = 1:20), + paste0("Parameter 'data' must be an array with three dimensions.")) + + data1 <- array(runif(min = -1, max = 1, n = 30), dim=c(5,3,2)) + expect_error( + PlotTriangles4Categories(data = data1), + paste0("Parameter 'data' must be an array with named dimensions.")) + + data1 <- runif(min = -1, max = 1, n = 30) + dim(data1) <- c(dim1 = 5, dim2 = 2, dim3 = 3) + expect_error( + PlotTriangles4Categories(data = data1), + paste0("Parameter 'data' should contain 'dimx', 'dimy' and 'dimcat' dimension names.")) + + data1 <- runif(min = -1, max = 1, n = 30) + dim(data1) <- c(dimx = 5, dimy =2 , dimcat=3) + expect_error( + PlotTriangles4Categories(data = data1), + paste0("Parameter 'data' should contain a dimcat dimension with length equals + to two or four as only two or four categories can be plotted")) + + data1 <- runif(min = -1, max = 1, n = 30) + data1[5:10] <- NA + dim(data1) <- c(dimx = 5, dimy =3 , dimcat=2) + expect_error( + PlotTriangles4Categories(data = data1), + paste0("Parameter 'data' cannot contain NAs.")) + + data1 <- runif(min = -1, max = 1, n = 30) + dim(data1) <- c(dimx = 5, dimy =3 , dimcat=2) + expect_error( + PlotTriangles4Categories(data = data1,sig_data = 0.5), + paste0("Parameter 'sig_data' array must be logical.")) + + expect_error( + PlotTriangles4Categories(data = data1, sig_data = TRUE), + paste0("Parameter 'sig_data' must be an array with three dimensions.")) + + sig1 <- array(TRUE, dim=c(5,2,3)) + expect_error( + PlotTriangles4Categories(data = data1, sig_data = sig1), + paste0("Parameter 'sig_data' must be an array with the same dimensions as 'data'")) + + sig1 <- array(TRUE, dim= c(5,3,2)) + dim(sig1) <- c(dimy = 5, dimx =3 , dimcat=2) + expect_error( + PlotTriangles4Categories(data = data1, sig_data = sig1), + paste0("Parameter 'sig_data' must be an array with the same named dimensions as 'data'.")) + + data1 <- runif(min = -1, max = 1, n = 30) + dim(data1) <- c(dimx = 5, dimy =3 , dimcat=2) + expect_error( + PlotTriangles4Categories(data = data1, lab_legend = c('1','2','3')), + paste0("Parameter 'lab_legend' should contain two or four names.")) + +expect_error( + PlotTriangles4Categories(data = data1, brks=c(-1,0,1),cols=c('blue','red','black')), + paste0("The length of the parameter 'brks' must be one more than 'cols'.")) + + + +}) -- GitLab From a150dc17fcaa05f767224854204ae937f574b4ac Mon Sep 17 00:00:00 2001 From: nperez Date: Tue, 16 Jun 2020 20:13:00 +0200 Subject: [PATCH 8/8] PlotTriangles4Categories added to news --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index f108f5db..f81ad720 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,7 @@ + EnsClustering has a new parameter 'time_dim' + CST_BiasCorrection has na.rm paramter + CST_Anomaly allows to smooth the climatology with filter.span parameter + + PlotTriangles4Categories new plotting function to convert any 3-d numerical array to a grid of coloured triangles. - Fixes + CST_Anomaly handles exp, obs or both + PlotForecastPDF vignette displays figures correctly -- GitLab