From 1428c7a9f3ac31edf3b6410586bb9b57c20a2f75 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 31 Jan 2020 11:25:10 +0100 Subject: [PATCH 1/2] Copy .R and .Rd of nine new functions from s2dverification develop-Apply branch --- R/Clim.R | 408 +++++++++++ R/Corr.R | 293 ++++++++ R/Eno.R | 109 +++ R/InsertDim.R | 119 ++++ R/RMS.R | 243 +++++++ R/RMSSS.R | 210 ++++++ R/Regression.R | 250 +++++++ R/Season.R | 152 +++++ R/Trend.R | 182 +++++ R/Utils.R | 1657 +++++++++++++++++++++++++++++++++++++++++++++ man/Clim.Rd | 92 +++ man/Corr.Rd | 105 +++ man/Eno.Rd | 49 ++ man/InsertDim.Rd | 43 ++ man/RMS.Rd | 93 +++ man/RMSSS.Rd | 73 ++ man/Regression.Rd | 101 +++ man/Season.Rd | 56 ++ man/Trend.Rd | 82 +++ 19 files changed, 4317 insertions(+) create mode 100644 R/Clim.R create mode 100644 R/Corr.R create mode 100644 R/Eno.R create mode 100644 R/InsertDim.R create mode 100644 R/RMS.R create mode 100644 R/RMSSS.R create mode 100644 R/Regression.R create mode 100644 R/Season.R create mode 100644 R/Trend.R create mode 100644 R/Utils.R create mode 100644 man/Clim.Rd create mode 100644 man/Corr.Rd create mode 100644 man/Eno.Rd create mode 100644 man/InsertDim.Rd create mode 100644 man/RMS.Rd create mode 100644 man/RMSSS.Rd create mode 100644 man/Regression.Rd create mode 100644 man/Season.Rd create mode 100644 man/Trend.Rd diff --git a/R/Clim.R b/R/Clim.R new file mode 100644 index 0000000..7f165d3 --- /dev/null +++ b/R/Clim.R @@ -0,0 +1,408 @@ +#'Compute Bias Corrected Climatologies +#' +#'This function computes per-pair climatologies for the experimental +#'and observational data using one of the following methods: +#'\enumerate{ +#' \item{per-pair method (Garcia-Serrano and Doblas-Reyes, CD, 2012)} +#' \item{Kharin method (Karin et al, GRL, 2012)} +#' \item{Fuckar method (Fuckar et al, GRL, 2014)} +#'} +#'Per-pair climatology means that only the startdates covered by the +#'whole experiments/observational dataset will be used. In other words, the +#'startdates which are not all available along 'dat_dim' dimension of both +#'the 'exp' and 'obs' are excluded when computing the climatologies. +#' +#'@param exp A named numeric array of experimental data, with at least two +#' dimensions 'time_dim' and 'dat_dim'. +#'@param obs A named numeric array of observational data, same dimensions as +#' parameter 'exp' except along 'dat_dim'. +#'@param time_dim A character string indicating the name of dimension along +#' which the climatologies are computed. The default value is 'sdate'. +#'@param dat_dim A character vector indicating the name of the dataset and +#' member dimensions. If data at one startdate (i.e., 'time_dim') are not +#' complete along 'dat_dim', this startdate along 'dat_dim' will be discarded. +#' The default value is "c('dataset', 'member')". +#'@param method A character string indicating the method to be used. The +#' options include 'clim', 'kharin', and 'NDV'. The default value is 'clim'. +#'@param ftime_dim A character string indicating the name of forecast time +#' dimension. Only used when method = 'NDV'. The default value is 'ftime'. +#'@param memb_dim A character string indicating the name of the member +#' dimension. Only used when parameter 'memb' is FALSE. It must be one element +#' in 'dat_dim'. The default value is 'member'. +#'@param memb A logical value indicating whether to remain 'memb_dim' dimension +#' (TRUE) or do ensemble mean over 'memb_dim' (FALSE). The default value is TRUE. +#'@param na.rm A logical value indicating whether to remove NA values along +#' 'time_dim' when calculating climatology (TRUE) or return NA if there is NA +#' along 'time_dim' (FALSE). The default value is TRUE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list of 2: +#'\item{$clim_exp}{ +#' A numeric array with the same dimensions as parameter 'exp' but +#' dimension 'time_dim' is moved to the first position. If parameter 'method' +#' is 'clim', dimension 'time_dim' is removed. If parameter 'memb' is FALSE, +#' dimension 'memb_dim' is also removed. +#'} +#'\item{$clim_obs}{ +#' A numeric array with the same dimensions as parameter 'exp' +#' except dimension 'time_dim' is removed. If parameter 'memb' is FALSE, +#' dimension 'memb_dim' is also removed. +#'} +#' +#'@keywords datagen +#'@author History:\cr +#' 0.9 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +#' 1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN +#' 3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adopt multiApply feature +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'clim2 <- Clim(sampleData$mod, sampleData$obs, method = 'kharin', memb = F) +#'\donttest{ +#'PlotClim(clim$clim_exp, clim$clim_obs, +#' toptitle = paste('sea surface temperature climatologies'), +#' ytitle = 'K', monini = 11, listexp = c('CMIP5 IC3'), +#' listobs = c('ERSST'), biglab = FALSE, fileout = 'tos_clim.eps') +#'} +#'@importFrom abind adrop +#'@import multiApply +#'@export +Clim <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), + method = 'clim', ftime_dim = 'ftime', memb_dim = 'member', + memb = TRUE, na.rm = TRUE, ncores = NULL) { + + # Check inputs + ## exp and obs (1) + if (is.null(exp) | is.null(obs)) { + stop("Parameter 'exp' and 'obs' cannot be NULL.") + } + if (!is.numeric(exp) | !is.numeric(obs)) { + stop("Parameter 'exp' and 'obs' must be a numeric array.") + } + if (is.null(dim(exp)) | is.null(dim(obs))) { + stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and dat_dim.")) + } + if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + if(!all(names(dim(exp)) %in% names(dim(obs))) | + !all(names(dim(obs)) %in% names(dim(exp)))) { + stop("Parameter 'exp' and 'obs' must have same dimension name") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + ## dat_dim + if (!is.character(dat_dim)) { + stop("Parameter 'dat_dim' must be a character vector.") + } + if (!all(dat_dim %in% names(dim(exp))) | !all(dat_dim %in% names(dim(obs)))) { + stop("Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension.") + } + ## method + if (!(method %in% c("clim", "kharin", "NDV"))) { + stop("Parameter 'method' must be one of 'clim', 'kharin' or 'NDV'.") + } + ## ftime_dim + if (!is.character(ftime_dim) | length(ftime_dim) > 1) { + stop("Parameter 'ftime_dim' must be a character string.") + } + if (!ftime_dim %in% names(dim(exp)) | !ftime_dim %in% names(dim(obs))) { + stop("Parameter 'ftime_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp)) | !memb_dim %in% names(dim(obs))) { + stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb + if (!is.logical(memb) | length(memb) > 1) { + stop("Parameter 'memb' must be one logical value.") + } + ## na.rm + if (!is.logical(na.rm) | length(na.rm) > 1) { + stop("Parameter 'na.rm' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + ## exp and obs (2) + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + for (i in 1:length(dat_dim)) { + name_exp <- name_exp[-which(name_exp == dat_dim[i])] + name_obs <- name_obs[-which(name_obs == dat_dim[i])] + } + if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimension expect 'dat_dim'.")) + } + + ############################### + # Sort dimension + name_exp <- names(dim(exp)) + name_obs <- names(dim(obs)) + order_obs <- match(name_exp, name_obs) + obs <- .aperm2(obs, order_obs) + + + ############################### + # Calculate Clim + + #---------------------------------- + # Remove all sdate if not complete along dat_dim + + pos <- rep(0, length(dat_dim)) + for (i in 1:length(dat_dim)) { #[dat, sdate] + ## dat_dim: [dataset, member] + pos[i] <- which(names(dim(obs)) == dat_dim[i]) + } + outrows_exp <- MeanListDim(exp, pos, narm = FALSE) + + MeanListDim(obs, pos, narm = FALSE) + outrows_obs <- outrows_exp + + for (i in 1:length(pos)) { + outrows_exp <- InsertDim(outrows_exp, pos[i], dim(exp)[pos[i]]) + outrows_obs <- InsertDim(outrows_obs, pos[i], dim(obs)[pos[i]]) + } + exp[which(is.na(outrows_exp))] <- NA + obs[which(is.na(outrows_obs))] <- NA + + #----------------------------------- + + if (method == 'clim') { + clim <- Apply(list(exp, obs), + target_dims = c(time_dim, dat_dim), + fun = .Clim, + method = method, time_dim = time_dim, + dat_dim = dat_dim, ftime_dim = ftime_dim, memb_dim = memb_dim, + memb = memb, na.rm = na.rm, + ncores = ncores) + # Add member dimension name back + if (memb) { + if(is.null(names(dim(clim$clim_exp))[1])) { + names(dim(clim$clim_exp))[1] <- memb_dim + names(dim(clim$clim_obs))[1] <- memb_dim + } + } + + } else if (method == 'kharin') { + clim <- Apply(list(exp, obs), + target_dims = c(time_dim, dat_dim), + fun = .Clim, + method = method, time_dim = time_dim, + dat_dim = dat_dim, ftime_dim = ftime_dim, memb_dim = memb_dim, + memb = memb, na.rm = na.rm, + ncores = ncores) + + } else if (method == 'NDV') { + clim <- Apply(list(exp, obs), + target_dims = c(time_dim, dat_dim, ftime_dim), + fun = .Clim, + method = method, time_dim = time_dim, + dat_dim = dat_dim, ftime_dim = ftime_dim, memb_dim = memb_dim, + memb = memb, na.rm = na.rm, + ncores = ncores) + } + + return(clim) +} + + +.Clim <- function(exp, obs, method = 'clim', + time_dim = 'sdate', dat_dim = c('dataset', 'member'), + ftime_dim = 'ftime', memb_dim = 'member', memb = TRUE, + na.rm = TRUE) { + + if (method == 'clim') { + # exp: [sdate, dat_dim_exp] + # obs: [sdate, dat_dim_obs] + + clim_exp <- apply(exp, which(names(dim(exp)) != time_dim), + mean, na.rm = na.rm) #average out time_dim + clim_obs <- apply(obs, which(names(dim(obs)) != time_dim), + mean, na.rm = na.rm) #[dat_dim] + + ## member mean + if (!memb) { + if (length(dim(clim_exp)) == 1) { #dim: [member] + clim_exp <- mean(clim_exp, na.rm = TRUE) + clim_obs <- mean(clim_obs, na.rm = TRUE) + } else { + pos <- which(names(dim(clim_exp)) == memb_dim) + pos <- c(1:length(dim(clim_exp)))[-pos] + dim_name <- names(dim(clim_exp)) + clim_exp <- apply(clim_exp, pos, mean, na.rm = TRUE) + clim_obs <- apply(clim_obs, pos, mean, na.rm = TRUE) + if (is.null(names(dim(as.array(clim_exp))))) { + clim_exp <- as.array(clim_exp) + clim_obs <- as.array(clim_obs) + names(dim(clim_exp)) <- dim_name[pos] + names(dim(clim_obs)) <- dim_name[pos] + } + } + } + + } else if (method == 'kharin') { + # exp: [sdate, dat_dim_exp] + # obs: [sdate, dat_dim_obs] + + # obs clim + clim_obs <- apply(obs, which(names(dim(obs)) != time_dim), + mean, na.rm = na.rm) #[dat_dim] + + # exp clim + ##--- NEW trend ---## + tmp_obs <- Trend(data = obs, time_dim = time_dim, interval = 1, + polydeg = 1, conf = FALSE)$trend + tmp_exp <- Trend(data = exp, time_dim = time_dim, interval = 1, + polydeg = 1, conf = FALSE)$trend + # tmp_exp: [stats, dat_dim)] + + tmp_obs_mean <- apply(tmp_obs, 1, mean) #average out dat_dim (dat and member) + #tmp_obs_mean: [stats = 2] + + intercept_exp <- Subset(tmp_exp, 1, 1, drop = 'selected') #[dat_dim] + slope_exp <- Subset(tmp_exp, 1, 2, drop = 'selected') #[dat_dim] + intercept_obs <- array(tmp_obs_mean[1], dim = dim(exp)[-1]) #[dat_dim] + slope_obs <- array(tmp_obs_mean[2], dim = dim(exp)[-1]) #[dat_dim] + trend_exp <- list() + trend_obs <- list() + + for (jdate in 1:dim(exp)[time_dim]) { + trend_exp[[jdate]] <- intercept_exp + jdate * slope_exp + trend_obs[[jdate]] <- intercept_obs + jdate * slope_obs + } + # turn list into array + trend_exp <- array(unlist(trend_exp), dim = c(dim(exp)[-1], dim(exp)[1])) + trend_obs <- array(unlist(trend_obs), dim = c(dim(exp)[-1], dim(exp)[1])) + len <- length(dim(exp)) + trend_exp <- .aperm2(trend_exp, c(len, 1:(len - 1))) + trend_obs <- .aperm2(trend_obs, c(len, 1:(len - 1))) + + clim_obs_mean <- mean(apply(clim_obs, 1, mean)) #average out dat_dim, get a number + clim_obs_mean <- array(clim_obs_mean, dim = dim(exp)) #enlarge it for the next line + clim_exp <- trend_exp - trend_obs + clim_obs_mean + + ## member mean + if (!memb) { + pos <- which(names(dim(clim_exp)) == memb_dim) + pos <- c(1:length(dim(clim_exp)))[-pos] + dim_name <- names(dim(clim_exp)) + clim_exp <- apply(clim_exp, pos, mean, na.rm = TRUE) + clim_obs <- apply(clim_obs, pos, mean, na.rm = TRUE) + if (is.null(names(dim(as.array(clim_exp))))) { + clim_exp <- as.array(clim_exp) + clim_obs <- as.array(clim_obs) + names(dim(clim_exp)) <- dim_name[pos] + names(dim(clim_obs)) <- dim_name[pos] + } + } + + + } else if (method == 'NDV') { + # exp: [sdate, dat_dim, ftime] + # obs: [sdate, dat_dim, ftime] + + # obs clim + clim_obs <- apply(obs, which(names(dim(obs)) != time_dim), + mean, na.rm = na.rm) #[dat_dim, ftime] + + # exp clim + pos_ftime <- length(dim(exp)) #a number + dim_ftime <- dim(exp)[pos_ftime] #c(ftime = 4) + pos_dat <- 2:(length(dim(exp)) - 1) #1 is sdate, last is ftime + dim_dat <- dim(exp)[pos_dat] #c(dataset = 1, member = 3) + + # Create initial data set (i.e., only first ftime) + tmp <- Subset(exp, ftime_dim, 1, drop = 'selected') + ini_exp <- InsertDim(tmp, pos_ftime, dim_ftime) #only first ftime + tmp <- Subset(obs, ftime_dim, 1, drop = 'selected') + ini_obs <- InsertDim(tmp, pos_ftime, dim_ftime) #only first ftime + #ini_: [sdate, dat_dim, ftime] + tmp_exp <- Regression(datay = exp, datax = ini_exp, time_dim = time_dim, + na.action = na.omit, + pval = FALSE, conf = FALSE)$regression + tmp_obs <- Regression(datay = obs, datax = ini_obs, time_dim = time_dim, + na.action = na.omit, + pval = FALSE, conf = FALSE)$regression + #tmp_: [stats = 2, dat_dim, ftime] + tmp_obs_mean <- apply(tmp_obs, c(1, length(dim(tmp_obs))), mean) #average out dat_dim (dat and member) + #tmp_obs_mean: [stats = 2, ftime] + ini_obs_mean <- apply(ini_obs, c(1, length(dim(ini_obs))), mean) #average out dat_dim + #ini_obs_mean: [sdate, ftime] + + # Find intercept and slope + intercept_exp <- Subset(tmp_exp, 1, 1, drop = 'selected') #[dat_dim, ftime] + slope_exp <- Subset(tmp_exp, 1, 2, drop = 'selected') #[dat_dim, ftime] + intercept_obs <- array(tmp_obs_mean[1, ], dim = c(dim_ftime, dim_dat)) + #[ftime, dat_dim] exp + intercept_obs <- .aperm2(intercept_obs, c(2:length(dim(intercept_obs)), 1)) + #[dat_dim, ftime] exp + slope_obs <- array(tmp_obs_mean[2, ], dim = c(dim_ftime, dim_dat)) + #[ftime, dat_dim] exp + slope_obs <- .aperm2(slope_obs, c(2:length(dim(slope_obs)), 1)) + #[dat_dim, ftime] exp + + trend_exp <- list() + trend_obs <- list() + for (jdate in 1:dim(exp)[time_dim]) { + tmp <- Subset(ini_exp, time_dim, jdate, drop = 'selected') #[dat_dim, ftime] + trend_exp[[jdate]] <- intercept_exp + tmp * slope_exp #[dat_dim, ftime] + + tmp <- array(ini_obs_mean[jdate, ], dim = c(dim_ftime, dim_dat)) #[ftime, dat_dim] + tmp <- .aperm2(tmp, c(2:length(dim(tmp)), 1)) #[dat_dim, ftime] + trend_obs[[jdate]] <- intercept_obs + tmp * slope_obs + } + # turn list into array + trend_exp <- array(unlist(trend_exp), dim = c(dim(exp)[-1], dim(exp)[1])) + trend_obs <- array(unlist(trend_obs), dim = c(dim(exp)[-1], dim(exp)[1])) + #trend_: [dat_dim, ftime, sdate] + len <- length(dim(exp)) + trend_exp <- .aperm2(trend_exp, c(len, 1:(len - 1))) + trend_obs <- .aperm2(trend_obs, c(len, 1:(len - 1))) + #trend_: [sdate, dat_dim, ftime] + + clim_obs_mean <- apply(clim_obs, length(dim(clim_obs)), mean) #average out dat_dim, [ftime] + clim_obs_mean <- array(clim_obs_mean, dim = c(dim_ftime, dim(exp)[1], dim_dat)) + #[ftime, sdate, dat_dim] + len <- length(dim(clim_obs_mean)) + clim_obs_mean <- .aperm2(clim_obs_mean, c(2:len, 1)) + #[sdate, dat_dim, ftime] + + clim_exp <- trend_exp - trend_obs + clim_obs_mean + + ## member mean + if (!memb) { + pos <- which(names(dim(clim_exp)) == memb_dim) + pos <- c(1:length(dim(clim_exp)))[-pos] + dim_name <- names(dim(clim_exp)) + clim_exp <- apply(clim_exp, pos, mean, na.rm = TRUE) + clim_obs <- apply(clim_obs, pos, mean, na.rm = TRUE) + if (is.null(names(dim(as.array(clim_exp))))) { + clim_exp <- as.array(clim_exp) + clim_obs <- as.array(clim_obs) + names(dim(clim_exp)) <- dim_name[pos] + names(dim(clim_obs)) <- dim_name[pos] + } + } + + } + + return(list(clim_exp = clim_exp, clim_obs = clim_obs)) +} diff --git a/R/Corr.R b/R/Corr.R new file mode 100644 index 0000000..b8463ed --- /dev/null +++ b/R/Corr.R @@ -0,0 +1,293 @@ +#'Compute the correlation coefficient between an array of forecast and their corresponding observation +#' +#'Calculate the correlation coefficient (Pearson, Kendall or Spearman) for +#'an array of forecast and an array of observation. The correlations are +#'computed along time_dim, the startdate dimension. If comp_dim is given, +#'the correlations are computed only if data along the comp_dim dimension are +#'complete between limits[1] and limits[2], i.e., there is no NA between +#'limits[1] and limits[2]. This option can be activated if the user wants to +#'account only for the forecasts which the corresponding observations are +#'available at all leadtimes.\cr +#'The confidence interval is computed by the Fisher transformation and the +#'significance level relies on an one-sided student-T distribution.\cr +#' +#'@param exp A named numeric array of experimental data, with at least two +#' dimensions 'time_dim' and 'memb_dim'. +#'@param obs A named numeric array of observational data, same dimensions as +#' parameter 'exp' except along memb_dim. +#'@param time_dim A character string indicating the name of dimension along +#' which the correlations are computed. The default value is 'sdate'. +#'@param memb_dim A character string indicating the name of member (nobs/nexp) +#' dimension. The default value is 'member'. +#'@param comp_dim A character string indicating the name of dimension along which +#' the data is taken into account only if it is complete. The default value +#' is NULL. +#'@param limits A vector of two integers indicating the range along comp_dim to +#' be completed. The default is c(1, length(comp_dim dimension)). +#'@param method A character string indicating the type of correlation: +#' 'pearson', 'spearman', or 'kendall'. The default value is 'pearson'. +#'@param pval A logical value indicating whether to compute or not the p-value +#' of the test Ho: Corr = 0. The default value is TRUE. +#'@param conf A logical value indicating whether to retrieve the confidence +#' intervals or not. The default value is TRUE. +#'@param conf.lev A numeric indicating the confidence level for the +#' regression computation. The default value is 0.95. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list containing the numeric arrays with dimension:\cr +#' c(nexp, nobs, all other dimensions of exp except time_dim).\cr +#'nexp is the number of experiment (i.e., memb_dim in exp), and nobs is the +#'number of observation (i.e., memb_dim in obs).\cr +#'\item{$corr}{ +#' The correlation coefficient. +#'} +#'\item{$p.val}{ +#' The p-value. Only present if \code{pval = TRUE}. +#'} +#'\item{$conf.lower}{ +#' The lower confidence interval. Only present if \code{conf = TRUE}. +#'} +#'\item{$conf.upper}{ +#' The upper confidence interval. Only present if \code{conf = TRUE}. +#'} +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-04 (V. Guemas, \email{vguemas@bsc.es}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to R CRAN\cr +#'1.1 - 2014-10 (M. Menegoz, \email{martin.menegoz@bsc.es}) - Adding conf.lev argument\cr +#'1.2 - 2015-03 (L.P. Caron, \email{louis-philippe.caron@@bsc.es}) - Adding method argument\cr +#'1.3 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapted to veriApply() +#'3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'runmean_months <- 12 +#'dim_to_smooth <- 4 +#'# Smooth along lead-times +#'smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +#'smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +#'leadtimes_per_startdate <- 60 +#'corr <- Corr(smooth_ano_exp, +#' smooth_ano_obs, +#' comp_dim = 'ftime', #Discard start dates which contain any NA ftime +#' limits = c(ceiling((runmean_months + 1) / 2), +#' leadtimes_per_startdate - floor(runmean_months / 2))) +#' +#'@rdname Corr +#'@import multiApply +#'@importFrom stats cor pt qnorm +#'@export +Corr <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', + comp_dim = NULL, limits = NULL, + method = 'pearson', pval = TRUE, conf = TRUE, + conf.lev = 0.95, ncores = NULL) { + + # Check inputs + ## exp and obs (1) + if (is.null(exp) | is.null(obs)) { + stop("Parameter 'exp' and 'obs' cannot be NULL.") + } + if (!is.numeric(exp) | !is.numeric(obs)) { + stop("Parameter 'exp' and 'obs' must be a numeric array.") + } + if (is.null(dim(exp)) | is.null(dim(obs))) { + stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and memb_dim.")) + } + if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + if(!all(names(dim(exp)) %in% names(dim(obs))) | + !all(names(dim(obs)) %in% names(dim(exp)))) { + stop("Parameter 'exp' and 'obs' must have same dimension name") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp)) | !memb_dim %in% names(dim(obs))) { + stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + } + ## comp_dim + if (!is.null(comp_dim)) { + if (!is.character(comp_dim) | length(comp_dim) > 1) { + stop("Parameter 'comp_dim' must be a character string.") + } + if (!comp_dim %in% names(dim(exp)) | !comp_dim %in% names(dim(obs))) { + stop("Parameter 'comp_dim' is not found in 'exp' or 'obs' dimension.") + } + } + ## limits + if (!is.null(limits)) { + if (is.null(comp_dim)) { + stop("Paramter 'comp_dim' cannot be NULL if 'limits' is assigned.") + } + if (!is.numeric(limits) | any(limits %% 1 != 0) | any(limits < 0) | + length(limits) != 2 | any(limits > dim(exp)[comp_dim])) { + stop(paste0("Parameter 'limits' must be a vector of two positive ", + "integers smaller than the length of paramter 'comp_dim'.")) + } + } + ## method + if (!(method %in% c("kendall", "spearman", "pearson"))) { + stop("Parameter 'method' must be one of 'kendall', 'spearman' or 'pearson'.") + } + ## pval + if (!is.logical(pval) | length(pval) > 1) { + stop("Parameter 'pval' must be one logical value.") + } + ## conf + if (!is.logical(conf) | length(conf) > 1) { + stop("Parameter 'conf' must be one logical value.") + } + ## conf.lev + if (!is.numeric(conf.lev) | conf.lev < 0 | conf.lev > 1 | length(conf.lev) > 1) { + stop("Parameter 'conf.lev' must be a numeric number between 0 and 1.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + ## exp and obs (2) + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + name_exp <- name_exp[-which(name_exp == memb_dim)] + name_obs <- name_obs[-which(name_obs == memb_dim)] + if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimension expect 'memb_dim'.")) + } + if (dim(exp)[time_dim] < 3) { + stop("The length of time_dim must be at least 3 to compute correlation.") + } + + + ############################### + # Sort dimension + name_exp <- names(dim(exp)) + name_obs <- names(dim(obs)) + order_obs <- match(name_exp, name_obs) + obs <- .aperm2(obs, order_obs) + + + ############################### + # Calculate Corr + + # Remove data along comp_dim dim if there is at least one NA between limits + if (!is.null(comp_dim)) { + if (is.null(limits)) { + limits <- c(1, dim(obs)[comp_dim]) + } + pos <- which(names(dim(obs)) == comp_dim) + outrows <- is.na(Mean1Dim(obs, pos, narm = FALSE, limits)) + outrows <- InsertDim(outrows, pos, dim(obs)[comp_dim]) + obs[which(outrows)] <- NA + } + + res <- Apply(list(exp, obs), + target_dims = list(c(time_dim, memb_dim), + c(time_dim, memb_dim)), + fun = .Corr, + time_dim = time_dim, method = method, + pval = pval, conf = conf, conf.lev = conf.lev, + ncores = ncores) + return(res) +} + +.Corr <- function(exp, obs, time_dim = 'sdate', method = 'pearson', + conf = TRUE, pval = TRUE, conf.lev = 0.95) { + + # exp: [sdate, member_exp] + # obs: [sdate, member_obs] + n_exp <- as.numeric(dim(exp)[2]) + n_obs <- as.numeric(dim(obs)[2]) + + CORR <- array(dim = c(n_exp = n_exp, n_obs = n_obs)) + eno_expand <- array(dim = c(n_exp = n_exp, n_obs = n_obs)) + p.val <- array(dim = c(n_exp = n_exp, n_obs = n_obs)) + + # ens_mean + for (i in 1:n_obs) { + + CORR[, i] <- sapply(1:n_exp, + function(x) { + if (any(!is.na(exp[, x])) && sum(!is.na(obs[, i])) > 2) { +cor(exp[, x], obs[, i], + use = "pairwise.complete.obs", + method = method) +} else { + CORR[, i] <- NA +} +}) + } + +# if (pval) { +# for (i in 1:n_obs) { +# p.val[, i] <- try(sapply(1:n_exp, +# function(x) {(cor.test(exp[, x], obs[, i], +# use = "pairwise.complete.obs", +# method = method)$p.value)/2}), silent = TRUE) +# if (class(p.val[, i]) == 'character') { +# p.val[, i] <- NA +# } +# } +# } + + if (pval | conf) { + if (method == "kendall" | method == "spearman") { + tmp <- apply(obs, 2, rank) + names(dim(tmp))[1] <- time_dim + eno <- Eno(tmp, time_dim) + } else if (method == "pearson") { + eno <- Eno(obs, time_dim) + } + for (i in 1:n_exp) { + eno_expand[i, ] <- eno + } + } +#############old################# +#This doesn't return error but it's diff from cor.test() when method is spearman and kendall + if (pval) { + t <-sqrt(CORR * CORR * (eno_expand - 2) / (1 - (CORR ^ 2))) + p.val <- pt(t, eno_expand - 2, lower.tail = FALSE) + } +################################### + if (conf) { + conf.lower <- (1 - conf.lev) / 2 + conf.upper <- 1 - conf.lower + conflow <- tanh(atanh(CORR) + qnorm(conf.lower) / sqrt(eno_expand - 3)) + confhigh <- tanh(atanh(CORR) + qnorm(conf.upper) / sqrt(eno_expand - 3)) + } + + if (pval & conf) { + res <- list(corr = CORR, p.val = p.val, + conf.lower = conflow, conf.upper = confhigh) + } else if (pval & !conf) { + res <- list(corr = CORR, p.val = p.val) + } else if (!pval & conf) { + res <- list(corr = CORR, + conf.lower = conflow, conf.upper = confhigh) + } else { + res <- list(corr = CORR) + } + + return(res) + +} diff --git a/R/Eno.R b/R/Eno.R new file mode 100644 index 0000000..bb27b92 --- /dev/null +++ b/R/Eno.R @@ -0,0 +1,109 @@ +#'Compute effective sample size with classical method +#' +#'Compute the number of effective samples along one dimension of an array. This +#'effective number of independent observations can be used in +#'statistical/inference tests.\cr +#'The calculation is based on eno function from Caio Coelho from rclim.txt. +#' +#'@param data A numeric array with named dimensions. +#'@param time_dim A function indicating the dimension along which to compute +#' the effective sample size. The default value is 'sdate'. +#'@param na.action A function. It can be na.pass (missing values are allowed) +#' or na.fail (no missing values are allowed). See details in stats::acf(). +#' The default value is na.pass. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return An array with the same dimension as parameter 'data' except the +#' time_dim dimension, which is removed after the computation. The array +#' indicates the number of effective sample along time_dim. +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-05 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN +#'3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Adopt multiApply feature +#' +#'@examples +#'set.seed(1) +#'data <- array(rnorm(800), dim = c(dataset = 1, member = 2, sdate = 4, +#' ftime = 4, lat = 10, lon = 10)) +#'na <- floor(runif(40, min = 1, max = 800)) +#'data[na] <- NA +#'res <- Eno(data) +#' +#'@importFrom stats acf na.pass na.fail +#'@import multiApply +#'@export +Eno <- function(data, time_dim = 'sdate', na.action = na.pass, ncores = NULL) { + + # Check inputs + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be a numeric array.") + } + if (is.null(dim(data))) { #is vector + dim(data) <- c(length(data)) + names(dim(data)) <- time_dim + } + if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + stop("Parameter 'data' must have dimension names.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + ## na.action + if (as.character(substitute(na.action)) != c("na.pass") & + as.character(substitute(na.action)) != c("na.fail")) { + stop("Parameter 'na.action' must be a function either na.pass or na.fail.") + } + if(as.character(substitute(na.action))== c("na.fail") && any(is.na(data))) { + stop(paste0("Calculation fails because NA is found in paratemter 'data', ", + "which is not accepted when ", + "parameter 'na.action' = na.fail.")) + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + ############################### + # Calculate Eno + + eno <- Apply(data = list(data), + target_dims = time_dim, + output_dims = NULL, + fun = .Eno, + na.action = na.action, + ncores = ncores)$output1 + + return(eno) +} + +.Eno <- function(x, na.action) { + n <- length(sort(x)) + if (n > 1) { + a <- acf(x, lag.max = n - 1, plot = FALSE, + na.action = na.action)$acf[2:n, 1, 1] + s <- 0 + for (k in 1:(n - 1)) { + s <- s + (((n - k) / n) * a[k]) + } + eno <- min(n / (1 + (2 * s)), n) + } else { + eno <- NA + } + + return(eno) +} + diff --git a/R/InsertDim.R b/R/InsertDim.R new file mode 100644 index 0000000..590df25 --- /dev/null +++ b/R/InsertDim.R @@ -0,0 +1,119 @@ +#'Add a named dimension to an array +#' +#'Insert an extra dimension into an array at position 'posdim' with length +#''lendim'. The array repeats along the new dimension. +#' +#'@param data An array to which the additional dimension to be added. +#'@param posdim An integer indicating the position of the new dimension. +#'@param lendim An integer indicating the length of the new dimension. +#'@param name A character string indicating the name for the new dimension. +#' The default value is NULL. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return An array as parameter 'data' but with the added named dimension. +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN\cr +#'1.1 - 2015-03 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Improvements +#'3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Modify with multiApply +#' +#'@examples +#'a <- array(rnorm(15), dim = c(a = 3, b = 1, c = 5, d = 1)) +#'res <- InsertDim(InsertDim(a, posdim = 2, lendim = 1, name = 'e'), 4, c(f = 2)) +#'dim(res) +#' +#'@import multiApply +#'@export +InsertDim <- function(data, posdim, lendim, name = NULL, ncores = NULL) { + + # Check inputs + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (is.vector(data) & !is.list(data)) { #is vector + data <- as.array(data) + } + if (!is.array(data)) { + stop("Parameter 'data' must be an array.") + } + ## posdim + if (!is.numeric(posdim)) { + stop("Parameter 'posdim' must be a positive integer.") + } else if (posdim %% 1 != 0 | posdim <= 0 | length(posdim) > 1) { + stop("Parameter 'posdim' must be a positive integer.") + } + if (posdim > (length(dim(data)) + 1)) { + stop("Parameter 'posdim' cannot excess the number of dimensions of parameter 'data' plus 1") + } + ## lendim + if (!is.numeric(lendim)) { + stop("Parameter 'lendim' must be a positive integer.") + } else if (lendim %% 1 != 0 | lendim <= 0 | length(lendim) > 1) { + stop("Parameter 'lendim' must be a positive integer.") + } + ## name + if (is.null(name)) { + if (is.null(names(lendim))) { + name <- 'new' + warning("The name of new dimension is not given. Set the name as 'new'.") + } else { + name <- names(lendim) + } + } else { + if (!is.character(name) | length(name) > 1) { + stop("Parameter 'name' must be a character string.") + } + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores)) { + stop("Parameter 'ncores' must be a positive integer.") + } else if (ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + ############################### + # Calculate InsertDim + + ## create output dimension + outdim <- lendim + if (posdim > 1) { + outdim <- c(dim(data)[1:(posdim - 1)], outdim) + } + if (posdim <= length(dim(data))) { + outdim <- c(outdim, dim(data)[posdim:length(dim(data))]) + } + ## create output array + outvar <- array(dim = c(outdim)) + ## give temporary names for Apply(). The name will be replaced by data in the end + names(dim(outvar)) <- paste0('D', 1:length(outdim)) + names(dim(outvar))[posdim] <- name #'new' + + res <- Apply(data = list(outvar), + margins = name, #'new', + fun = .InsertDim, + dat = data, + ncores = ncores)$output1 + + if (posdim != 1) { + if (posdim < length(outdim)) { + res <- .aperm2(res, c(1:(posdim - 1), length(outdim), posdim:(length(outdim) - 1))) + } else { #posdim = length(outdim) + res <- .aperm2(res, c(1:(posdim - 1), length(outdim))) + } + } else { + res <- .aperm2(res, c(length(outdim), 1:(length(outdim) - 1))) + } + + return(res) +} + +.InsertDim <- function(x, dat) { + x <- data + return(x) +} diff --git a/R/RMS.R b/R/RMS.R new file mode 100644 index 0000000..3a8b961 --- /dev/null +++ b/R/RMS.R @@ -0,0 +1,243 @@ +#'Compute root mean square error +#' +#'Compute the root mean square error for an array of forecasts and an array of +#'observations. The RMSEs are computed along time_dim, the dimension which +#'corresponds to the startdate dimension. If comp_dim is given, the RMSEs are +#'computed only if data along the comp_dim dimension are complete between +#'limits[1] and limits[2], i.e. there are no NAs between limits[1] and +#'limits[2]. This option can be activated if the user wishes to account only +#'for the forecasts for which the corresponding observations are available at +#'all leadtimes.\cr +#'The confidence interval is computed by the chi2 distribution.\cr +#' +#'@param exp A named numeric array of experimental data, with at least two +#' dimensions 'time_dim' and 'memb_dim'. +#'@param obs A named numeric array of observational data, same dimensions as +#' parameter 'exp' except along memb_dim. +#'@param time_dim A character string indicating the name of dimension along +#' which the correlations are computed. The default value is 'sdate'. +#'@param memb_dim A character string indicating the name of member (nobs/nexp) +#' dimension. The default value is 'member'. +#'@param comp_dim A character string indicating the name of dimension along which +#' the data is taken into account only if it is complete. The default value +#' is NULL. +#'@param limits A vector of two integers indicating the range along comp_dim to +#' be completed. The default value is c(1, length(comp_dim dimension)). +#'@param conf A logical value indicating whether to retrieve the confidence +#' intervals or not. The default value is TRUE. +#'@param conf.lev A numeric indicating the confidence level for the +#' regression computation. The default value is 0.95. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list containing the numeric arrays with dimension:\cr +#' c(nexp, nobs, all other dimensions of exp except time_dim).\cr +#'nexp is the number of experiment (i.e., memb_dim in exp), and nobs is the +#'number of observation (i.e., memb_dim in obs).\cr +#'\item{$rms}{ +#' The root mean square error. +#'} +#'\item{$conf.lower}{ +#' The lower confidence interval. Only present if \code{conf = TRUE}. +#'} +#'\item{$conf.upper}{ +#' The upper confidence interval. Only present if \code{conf = TRUE}. +#'} +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-05 (V. Guemas, \email{vguemas@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens2@ic3.cat}) - Formatting to R CRAN\cr +#'1.1 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapted to veriApply() +#'3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'runmean_months <- 12 +#'dim_to_smooth <- 4 # Smooth along lead-times +#'smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +#'smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +#'dim_to_mean <- 2 # Mean along members +#'# Discard start-dates for which some leadtimes are missing +#'leadtimes_per_startdate <- 60 +#'rms <- RMS(smooth_ano_exp, +#' smooth_ano_obs, +#' comp_dim = 'ftime', +#' limits = c(ceiling((runmean_months + 1) / 2), +#' leadtimes_per_startdate - floor(runmean_months / 2))) +#' +#'@rdname RMS +#'@import multiApply +#'@export +RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', + comp_dim = NULL, limits = NULL, + conf = TRUE, conf.lev = 0.95, ncores = NULL) { + # Check inputs + ## exp and obs (1) + if (is.null(exp) | is.null(obs)) { + stop("Parameter 'exp' and 'obs' cannot be NULL.") + } + if (!is.numeric(exp) | !is.numeric(obs)) { + stop("Parameter 'exp' and 'obs' must be a numeric array.") + } + if (is.null(dim(exp)) | is.null(dim(obs))) { + stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and memb_dim.")) + } + if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + if(!all(names(dim(exp)) %in% names(dim(obs))) | + !all(names(dim(obs)) %in% names(dim(exp)))) { + stop("Parameter 'exp' and 'obs' must have same dimension name") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp)) | !memb_dim %in% names(dim(obs))) { + stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + } + ## comp_dim + if (!is.null(comp_dim)) { + if (!is.character(comp_dim) | length(comp_dim) > 1) { + stop("Parameter 'comp_dim' must be a character string.") + } + if (!comp_dim %in% names(dim(exp)) | !comp_dim %in% names(dim(obs))) { + stop("Parameter 'comp_dim' is not found in 'exp' or 'obs' dimension.") + } + } + ## limits + if (!is.null(limits)) { + if (is.null(comp_dim)) { + stop("Paramter 'comp_dim' cannot be NULL if 'limits' is assigned.") + } + if (!is.numeric(limits) | any(limits %% 1 != 0) | any(limits < 0) | + length(limits) != 2 | any(limits > dim(exp)[comp_dim])) { + stop(paste0("Parameter 'limits' must be a vector of two positive ", + "integers smaller than the length of paramter 'comp_dim'.")) + } + } + ## conf + if (!is.logical(conf) | length(conf) > 1) { + stop("Parameter 'conf' must be one logical value.") + } + ## conf.lev + if (!is.numeric(conf.lev) | conf.lev < 0 | conf.lev > 1 | length(conf.lev) > 1) { + stop("Parameter 'conf.lev' must be a numeric number between 0 and 1.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + ## exp and obs (2) + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + name_exp <- name_exp[-which(name_exp == memb_dim)] + name_obs <- name_obs[-which(name_obs == memb_dim)] + if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimension expect 'memb_dim'.")) + } + if (dim(exp)[time_dim] < 2) { + stop("The length of time_dim must be at least 2 to compute RMS.") + } + + + ############################### + # Sort dimension + name_exp <- names(dim(exp)) + name_obs <- names(dim(obs)) + order_obs <- match(name_exp, name_obs) + obs <- .aperm2(obs, order_obs) + + + ############################### + # Calculate Corr + + # Remove data along comp_dim dim if there is at least one NA between limits + if (!is.null(comp_dim)) { + if (is.null(limits)) { + limits <- c(1, dim(obs)[comp_dim]) + } + pos <- which(names(dim(obs)) == comp_dim) + outrows <- is.na(Mean1Dim(obs, pos, narm = FALSE, limits)) + outrows <- InsertDim(outrows, pos, dim(obs)[comp_dim]) + obs[which(outrows)] <- NA + } + + res <- Apply(list(exp, obs), + target_dims = list(c(time_dim, memb_dim), + c(time_dim, memb_dim)), + fun = .RMS, + time_dim = time_dim, memb_dim = memb_dim, + conf = conf, conf.lev = conf.lev, ncores = ncores) + return(res) +} + + +.RMS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', + conf = TRUE, conf.lev = 0.95) { + + # exp: [sdate, member_exp] + # obs: [sdate, member_obs] + n_exp <- as.numeric(dim(exp)[2]) + n_obs <- as.numeric(dim(obs)[2]) + n_sdate <- as.numeric(dim(exp)[1]) + + dif <- array(dim = c(sdate = n_sdate, n_exp = n_exp, n_obs = n_obs)) + chi <- array(dim = c(nexp = n_exp, nobs = n_obs)) + if (conf) { + conflow <- (1 - conf.lev) / 2 + confhigh <- 1 - conflow + conf.lower <- array(dim = c(nexp = n_exp, nobs = n_obs)) + conf.upper <- array(dim = c(nexp = n_exp, nobs = n_obs)) + } + + # dif + for (i in 1:n_obs) { + dif[, , i] <- sapply(1:n_exp, function(x) {exp[, x] - obs[, i]}) + } + rms <- apply(dif^2, c(2, 3), mean, na.rm = TRUE)^0.5 #array(dim = c(n_exp, n_obs)) + + if (conf) { + #eno <- Eno(dif, 1) #count effective sample along sdate. dim = c(n_exp, n_obs) + eno <- Eno(dif, time_dim) #change to this line when Eno() is done + + # conf.lower + chi <- sapply(1:n_obs, function(i) { + qchisq(confhigh, eno[, i] - 1) + }) + conf.lower <- (eno * rms ** 2 / chi) ** 0.5 + + # conf.upper + chi <- sapply(1:n_obs, function(i) { + qchisq(conflow, eno[, i] - 1) + }) + conf.upper <- (eno * rms ** 2 / chi) ** 0.5 + } + + if (conf) { + res <- list(rms = rms, conf.lower = conf.lower, conf.upper = conf.upper) + } else { + res <- list(rms = rms) + } + + return(res) + +} diff --git a/R/RMSSS.R b/R/RMSSS.R new file mode 100644 index 0000000..53a6ec1 --- /dev/null +++ b/R/RMSSS.R @@ -0,0 +1,210 @@ +#'Compute root mean square error skill score +#' +#'Compute the root mean square error skill score (RMSSS) between an array of +#'forecast 'exp' and an array of observation 'obs'. The two arrays should +#'have the same dimensions except along memb_dim, where the length can be +#'different, with the number of experiments/models (nexp) and the number of +#'observational datasets (nobs).\cr +#'RMSSS computes the root mean square error skill score of each jexp in 1:nexp +#'against each jobs in 1:nobs which gives nexp * nobs RMSSS for each other +#'grid point of the array.\cr +#'The RMSSS are computed along the time_dim dimension which should corresponds +#'to the startdate dimension.\cr +#'The p-value is optionally provided by an one-sided Fisher test.\cr +#' +#'@param exp A named numeric array of experimental data which contains at least +#' two dimensions for memb_dim and time_dim. +#'@param obs A named numeric array of observational data which contains at least +#' two dimensions for memb_dim and time_dim. The dimensions should be the same +#' as paramter 'exp' except the length of 'memb_dim' dimension. The order of +#' dimension can be different. +#'@param memb_dim A character string indicating the name of member (nobs/nexp) +#' dimension. The default value is 'member'. +#'@param time_dim A character string indicating the name of dimension along +#' which the RMSSS are computed. The default value is 'sdate'. +#'@param pval A logical value indicating whether to compute or not the p-value +#' of the test Ho: RMSSS = 0. If pval = TRUE, the insignificant RMSSS will +#' return NA. The default value is TRUE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list containing the numeric arrays with dimension:\cr +#' c(nexp, nobs, all other dimensions of exp except time_dim).\cr +#'nexp is the number of experiment (i.e., memb_dim in exp), and nobs is the +#'number of observation (i.e., memb_dim in obs).\cr +#'\item{$rmsss}{ +#' The root mean square error skill score. +#'} +#'\item{$p.val}{ +#' The p-value. Only present if \code{pval = TRUE}. +#'} +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2012-04 (V. Guemas, \email{vguemas@bsc.es}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to R CRAN\cr +#'1.1 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapted to veriApply() +#'3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Adopt multiApply feature +#'@examples +#' set.seed(1) +#' exp <- array(rnorm(15), dim = c(dat = 1, time = 3, member = 5)) +#' set.seed(2) +#' obs <- array(rnorm(6), dim = c(time = 3, member = 2, dat = 1)) +#' res <- RMSSS(exp, obs, time_dim = 'time') +#' +#'@rdname RMSSS +#'@import multiApply +#'@export +RMSSS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', + pval = TRUE, ncores = NULL) { + + # Check inputs + ## exp and obs (1) + if (is.null(exp) | is.null(obs)) { + stop("Parameter 'exp' and 'obs' cannot be NULL.") + } + if (!is.numeric(exp) | !is.numeric(obs)) { + stop("Parameter 'exp' and 'obs' must be a numeric array.") + } + if (is.null(dim(exp)) | is.null(dim(obs))) { + stop(paste0("Parameter 'exp' and 'obs' must be at least two dimensions ", + "containing time_dim and memb_dim.")) + } + if(any(is.null(names(dim(exp))))| any(nchar(names(dim(exp))) == 0) | + any(is.null(names(dim(obs))))| any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'exp' and 'obs' must have dimension names.") + } + if(!all(names(dim(exp)) %in% names(dim(obs))) | + !all(names(dim(obs)) %in% names(dim(exp)))) { + stop("Parameter 'exp' and 'obs' must have same dimension name.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(exp)) | !time_dim %in% names(dim(obs))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) > 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(exp)) | !memb_dim %in% names(dim(obs))) { + stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + } + ## pval + if (!is.logical(pval) | length(pval) > 1) { + stop("Parameter 'pval' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + ## exp and obs (2) + name_exp <- sort(names(dim(exp))) + name_obs <- sort(names(dim(obs))) + name_exp <- name_exp[-which(name_exp == memb_dim)] + name_obs <- name_obs[-which(name_obs == memb_dim)] + if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + stop(paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimension expect 'memb_dim'.")) + } + if (dim(exp)[time_dim] <= 2) { + stop("The length of time_dim must be more than 2 to compute RMSSS.") + } + + + ############################### + # Sort dimension + name_exp <- names(dim(exp)) + name_obs <- names(dim(obs)) + order_obs <- match(name_exp, name_obs) + obs <- .aperm2(obs, order_obs) + + + ############################### + # Calculate RMSSS + + res <- Apply(list(exp, obs), + target_dims = list(c(time_dim, memb_dim), + c(time_dim, memb_dim)), + fun = .RMSSS, + time_dim = time_dim, memb_dim = memb_dim, + pval = pval, #conf = conf, conf.lev = conf.lev, + ncores = ncores) + + return(res) +} + +.RMSSS <- function(exp, obs, time_dim = 'sdate', memb_dim = 'member', pval = TRUE) { + # exp: [sdate, member_exp] + # obs: [sdate, member_obs] + n_exp <- as.numeric(dim(exp)[2]) + n_obs <- as.numeric(dim(obs)[2]) + n_sdate <- as.numeric(dim(exp)[1]) + + p_val <- array(dim = c(nexp = n_exp, nobs = n_obs)) + dif1 <- array(dim = c(n_sdate, n_exp, n_obs)) + names(dim(dif1)) <- c(time_dim, 'nexp', 'nobs') + +# if (conf) { +# conflow <- (1 - conf.lev) / 2 +# confhigh <- 1 - conflow +# conf_low <- array(dim = c(nexp = n_exp, nobs = n_obs)) +# conf_high <- array(dim = c(nexp = n_exp, nobs = n_obs)) +# } + + # dif1 + for (i in 1:n_obs) { + dif1[, , i] <- sapply(1:n_exp, function(x) {exp[, x] - obs[, i]}) + } + + # rms1 and eno1 + rms1 <- apply(dif1^2, c(2, 3), mean, na.rm = TRUE)^0.5 #array(dim = c(n_exp, n_obs)) + # rms2 and eno2 + rms2 <- array(colMeans(obs^2, na.rm = TRUE)^0.5, dim = c(n_obs = n_obs)) + rms2[which(abs(rms2) <= (max(abs(rms2), na.rm = TRUE) / 1000))] <- max(abs( + rms2), na.rm = TRUE) / 1000 + #rms2 above: [nobs] + rms2 <- array(rms2, dim = c(nobs = n_obs, nexp = n_exp)) + #rms2 above: [nobs, nexp] + rms2 <- .aperm2(rms2, c(2, 1)) + #rms2 above: [nexp, nobs] + + # use rms1 and rms2 to calculate rmsss + rmsss <- 1 - rms1/rms2 + + ## pval and conf + if (pval) { + eno1 <- Eno(dif1, time_dim) + eno2 <- Eno(obs, time_dim) + eno2 <- array(eno2, dim = c(nobs = n_obs, nexp = n_exp)) + eno2 <- .aperm2(eno2, c(2, 1)) + } + + # pval + if (pval) { + + F.stat <- (eno2 * rms2^2 / (eno2- 1)) / ((eno1 * rms1^2 / (eno1- 1))) + tmp <- !is.na(eno1) & !is.na(eno2) & eno1 > 2 & eno2 > 2 + p_val <- 1 - pf(F.stat, eno1 - 1, eno2 - 1) + p_val[which(!tmp)] <- NA + + # change not significant rmsss to NA + rmsss[which(!tmp)] <- NA + } + + # output + if (pval) { + res <- list(rmsss = rmsss, p.val = p_val) + + } else { + res <- list(rmsss = rmsss) + } + + return(res) +} diff --git a/R/Regression.R b/R/Regression.R new file mode 100644 index 0000000..a20bf45 --- /dev/null +++ b/R/Regression.R @@ -0,0 +1,250 @@ +#'Compute the regression of an array on another along one dimension. +#' +#'Compute the regression of the array 'datay' on the array 'datax' along the +#''time_dim' dimension by least square fitting (default) or self-defined model. +#'The function provides the slope of the regression, the intercept, and the +#'associated p-value and confidence interval. The filtered datay from the +#'regression onto datax is also provided.\cr +#'The p-value relies on the F distribution, and the confidence interval relies +#'on the student-T distribution. +#' +#'@param datay An numeric array as predictand including the dimension along +#' which the regression is computed. +#'@param datax An numeric array as predictor. The dimension should be identical +#' as parameter 'datay'. +#'@param time_dim A character string indicating the dimension along which to +#' compute the regression. +#'@param formula An object of class "formula" (see function \code{link[stats]{lm}}). +#'@param pval A logical value indicating whether to retrieve the p-value +#' or not. The default value is TRUE. +#'@param conf A logical value indicating whether to retrieve the confidence +#' intervals or not. The default value is TRUE. +#'@param conf.lev A numeric indicating the confidence level for the +#' regression computation. The default value is 0.95. +#'@param na.action A function or an integer. A function (e.g., na.omit, +#' na.exclude, na.fail, na.pass) indicates what should happen when the data +#' contain NAs. A numeric indicates the maximum number of NA position (it +#' counts as long as one of datay and datax is NA) allowed for compute +#' regression. The default value is na.omit- +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. Default value is NULL. +#' +#'@import multiApply +#'@return +#'\item{$regression}{ +#' A numeric array with same dimensions as parameter 'datay' and 'datax' except +#' the 'time_dim' dimension, which is replaced by a 'stats' dimension containing +#' the regression coefficients from the lowest order (i.e., intercept) to +#' the highest degree. The length of the 'stats' dimension should be +#' \code{polydeg + 1}. +#'} +#'\item{$conf.lower}{ +#' A numeric array with same dimensions as parameter 'daty' and 'datax' except +#' the 'time_dim' dimension, which is replaced by a 'stats' dimension containing +#' the lower value of the \code{siglev}\% confidence interval for all +#' the regression coefficients with the same order as $regression. The length +#' of 'stats' dimension should be \code{polydeg + 1}. Only present if +#' \code{conf = TRUE}. +#'} +#'\item{$conf.upper}{ +#' A numeric array with same dimensions as parameter 'daty' and 'datax' except +#' the 'time_dim' dimension, which is replaced by a 'stats' dimension containing +#' the upper value of the \code{siglev}\% confidence interval for all +#' the regression coefficients with the same order as $regression. The length +#' of 'stats' dimension should be \code{polydeg + 1}. Only present if +#' \code{conf = TRUE}. +#'} +#'\item{$p.val}{ +#' A numeric array with same dimensions as parameter 'daty' and 'datax' except +#' the 'time_dim' dimension, The array contains the p-value. +#'} +#'\item{$filtered}{ +#' A numeric array with the same dimension as paramter 'datay' and 'datax', +#' the filtered datay from the regression onto datax along the 'time_dim' +#' dimension. +#'} +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2013-05 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +#'2.0 - 2019-10 (N. Perez-Zanon, \email{nuria.perez@bsc.es}) - Formatting to multiApply +#'3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'datay <- sampleData$mod +#'datax <- sampleData$obs +#'datay <- Subset(datay, 'member', 2) +#'res1 <- Regression(datay, datax, formula = y~poly(x, 2, raw = TRUE)) +#'res2 <- Regression(datay, datax, conf.lev = 0.9) +#' +#'@importFrom stats lm na.omit confint +#'@import multiApply +#'@export +Regression <- function(datay, datax, time_dim = 'sdate', formula = y ~ x, + pval = TRUE, conf = TRUE, conf.lev = 0.95, + na.action = na.omit, ncores = NULL) { + + # Check inputs + ## datay and datax + if (is.null(datay) | is.null(datax)) { + stop("Parameter 'datay' and 'datax' cannot be NULL.") + } + if (!is.numeric(datay) | !is.numeric(datax)) { + stop("Parameter 'datay' and 'datax' must be a numeric array.") + } + if (is.null(dim(datay)) | is.null(dim(datax))) { + stop("Parameter 'datay' and 'datax' must be at least one dimension 'time_dim'.") + } + if(any(is.null(names(dim(datay))))| any(nchar(names(dim(datay))) == 0) | + any(is.null(names(dim(datax))))| any(nchar(names(dim(datax))) == 0)) { + stop("Parameter 'datay' and 'datax' must have dimension names.") + } + if(!all(names(dim(datay)) %in% names(dim(datax))) | + !all(names(dim(datax)) %in% names(dim(datay)))) { + stop("Parameter 'datay' and 'datax' must have same dimension name") + } + name_datay <- sort(names(dim(datay))) + name_datax <- sort(names(dim(datax))) + if(!all(dim(datay)[name_datay] == dim(datax)[name_datax])) { + stop("Parameter 'datay' and 'datax' must have same length of all dimensions.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(datay)) | !time_dim %in% names(dim(datax))) { + stop("Parameter 'time_dim' is not found in 'datay' or 'datax' dimension.") + } + ## formula + if (class(formula) != 'formula') { + stop("Parameter 'formula' must the an object of class 'formula'.") + } + ## pval + if (!is.logical(pval) | length(pval) > 1) { + stop("Parameter 'pval' must be one logical value.") + } + ## conf + if (!is.logical(conf) | length(conf) > 1) { + stop("Parameter 'conf' must be one logical value.") + } + ##conf.lev + if (!is.numeric(conf.lev) | conf.lev < 0 | conf.lev > 1 | length(conf.lev) > 1) { + stop("Parameter 'conf.lev' must be a numeric number between 0 and 1.") + } + ## na.action + if (!is.function(na.action) & !is.numeric(na.action)) { + stop(paste0("Parameter 'na.action' must be a function for NA values or ", + "a numeric indicating the number of NA values allowed ", + "before returning NA.")) + } + if (is.numeric(na.action)) { + if (any(na.action %% 1 != 0) | any(na.action < 0) | length(na.action) > 1) { + stop(paste0("Parameter 'na.action' must be a function for NA values or ", + "a numeric indicating the number of NA values allowed ", + "before returning NA.")) + } + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + ############################### + # Sort dimension + name_datay <- names(dim(datay)) + name_datax <- names(dim(datax)) + order_datax <- match(name_datay, name_datax) + datax <- .aperm2(datax, order_datax) + + + ############################### + # Calculate Regression + if (conf & pval) { + output_dims <- list(regression = 'stats', conf.lower = 'stats', + conf.upper = 'stats', p.val = NULL, filtered = time_dim) + } else if (conf & !pval) { + output_dims <- list(regression = 'stats', conf.lower = 'stats', + conf.upper = 'stats', filtered = time_dim) + } else if (!conf & pval) { + output_dims <- list(regression = 'stats', + p.val = NULL, filtered = time_dim) + } else if (!conf & !pval) { + output_dims <- list(regression = 'stats', filtered = time_dim) + } + + res <- Apply(list(datay, datax), + target_dims = time_dim, + output_dims = output_dims, + fun = .Regression, + formula = formula, pval = pval, conf = conf, + conf.lev = conf.lev, na.action = na.action, + ncores = ncores) + + return(invisible(res)) +} + + +.Regression <- function(y, x, formula = y~x, pval = TRUE, conf = TRUE, + conf.lev = 0.95, na.action = na.omit) { + + NApos <- 1:length(x) + NApos[which(is.na(x) | is.na(y))] <- NA + filtered <- rep(NA, length(x)) + check_na <- FALSE + + if (is.numeric(na.action)) { + na_threshold <- na.action + na.action <- na.omit + check_na <- TRUE + } + + # remove NAs for potential poly() + x2 <- x[!is.na(NApos)] + y2 <- y[!is.na(NApos)] + lm.out <- lm(formula, data = data.frame(x = x2, y = y2), na.action = na.action) + coeff <- lm.out$coefficients + if (conf) { + conf.lower <- confint(lm.out, level = conf.lev)[, 1] + conf.upper <- confint(lm.out, level = conf.lev)[, 2] + } + if (pval) { + f <- summary(lm.out)$fstatistic + p.val <- pf(f[1], f[2], f[3],lower.tail = F) + } + filtered[!is.na(NApos)] <- y[!is.na(NApos)] - lm.out$fitted.values + + # Check if NA is too many + if (check_na) { + if (sum(is.na(NApos)) > na_threshold) { #turn everything into NA + coeff[which(!is.na(coeff))] <- NA + if (conf) { + conf.lower[which(!is.na(conf.lower))] <- NA + conf.upper[which(!is.na(conf.upper))] <- NA + } + if (pval) { + p.val[which(!is.na(p.val))] <- NA + } + filtered[which(!is.na(filtered))] <- NA + } + } + + if (conf & pval) { + return(list(regression = coeff, conf.lower = conf.lower, conf.upper = conf.upper, + p.val = p.val, filtered = filtered)) + } else if (conf & !pval) { + return(list(regression = coeff, conf.lower = conf.lower, conf.upper = conf.upper, + filtered = filtered)) + } else if (!conf & pval) { + return(list(regression = coeff, + p.val = p.val, filtered = filtered)) + } else if (!conf & !pval) { + return(list(regression = coeff, filtered = filtered)) + } + +} + diff --git a/R/Season.R b/R/Season.R new file mode 100644 index 0000000..5ba9786 --- /dev/null +++ b/R/Season.R @@ -0,0 +1,152 @@ +#'Compute seasonal mean +#' +#'Compute the seasonal mean (or other methods) on monthly time series along +#'one dimension of a named multi-dimensional arrays. Partial season is not +#'accounted. +#' +#'@param data A named numeric array with at least one dimension 'time_dim'. +#'@param time_dim A character string indicating the name of dimension along +#' which the seasonal means are computed. The default value is 'sdate'. +#'@param monini An integer indicating what the first month of the time series is. +#' It can be from 1 to 12. +#'@param moninf An integer indicating the starting month of the seasonal mean. +#' It can be from 1 to 12. +#'@param monsup An integer indicating the end month of the seasonal mean. It +#' can be from 1 to 12. +#'@param method An R function to be applied for seasonal calculation. For +#' example, 'sum' can be used for total precipitation. The default value is mean. +#'@param na.rm A logical value indicating whether to remove NA values along +#' 'time_dim' when calculating climatology (TRUE) or return NA if there is NA +#' along 'time_dim' (FALSE). The default value is TRUE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return An array with the same dimensions as data except along the 'time_dim' +#' dimension, of which the length changes to the number of seasons. +#' +#'@import multiApply +#'@examples +#'set.seed(1) +#'dat1 <- array(rnorm(144*3), dim = c(member = 2, sdate = 12*3, ftime = 2, lon = 3)) +#'res <- Season(data = dat1, monini = 1, moninf = 1, monsup = 2) +#'res <- Season(data = dat1, monini = 10, moninf = 12, monsup = 2) +#'dat2 <- dat1 +#'set.seed(2) +#'na <- floor(runif(30, min = 1, max = 144*3)) +#'dat2[na] <- NA +#'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2) +#'res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2, na.rm = FALSE) +#'@import multiApply +#'@export +Season <- function(data, time_dim = 'sdate', monini, moninf, monsup, + method = mean, na.rm = TRUE, ncores = NULL) { + + # Check inputs + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be a numeric array.") + } + if (is.null(dim(data))) { #is vector + dim(data) <- c(length(data)) + names(dim(data)) <- time_dim + } + if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + stop("Parameter 'data' must have dimension names.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + ## monini + if (!is.numeric(monini)) { + stop("Parameter 'monini' must be a positive integer between 1 and 12.") + } else { + if (monini %% 1 != 0 | monini < 1 | monini > 12 | length(monini) > 1) { + stop("Parameter 'monini' must be a positive integer between 1 and 12.") + } + } + ## moninf + if (!is.numeric(moninf)) { + stop("Parameter 'moninf' must be a positive integer between 1 and 12.") + } else { + if (moninf %% 1 != 0 | moninf < 1 | moninf > 12 | length(moninf) > 1) { + stop("Parameter 'moninf' must be a positive integer between 1 and 12.") + } + } + ## monsup + if (!is.numeric(monsup)) { + stop("Parameter 'monsup' must be a positive integer between 1 and 12.") + } else { + if (monsup %% 1 != 0 | monsup < 1 | monsup > 12 | length(monsup) > 1) { + stop("Parameter 'monsup' must be a positive integer between 1 and 12.") + } + } + ## method + if (!is.function(method)) { + stop("Parameter 'method' should be an existing R function, e.g., mean or sum.") + } + ## na.rm + if (!is.logical(na.rm) | length(na.rm) > 1) { + stop("Parameter 'na.rm' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + ############################### + # Calculate Season + + # Correction need if monini is not January: + moninf <- moninf - monini + 1 + monsup <- monsup - monini + 1 + moninf <- ifelse(moninf <= 0, moninf + 12, moninf) + monsup <- ifelse(monsup <= 0, monsup + 12, monsup) + + while (monsup < moninf) { + monsup <- monsup + 12 + } + + res <- Apply(list(data), + target_dims = time_dim, + output_dims = time_dim, + fun = .Season, + monini = monini, moninf = moninf, monsup = monsup, + method = method, na.rm = na.rm, ncores = ncores)$output1 + + return(res) +} + +.Season <- function(x, monini, moninf, monsup, method = mean, na.rm = TRUE) { + + #### Create position index: + # Basic index: + pos <- moninf : monsup + # Extended index for all period: + if (length(x) > pos[length(pos)]) { + pos2 <- lapply(pos, function(y) {seq(y, length(x), 12)}) + } else { + pos2 <- pos + } + # Correct if the final season is not complete: + maxyear <- min(unlist(lapply(pos2, length))) + pos2 <- lapply(pos2, function(y) {y[1 : maxyear]}) + # Convert to array: + pos2 <- unlist(pos2) + dim(pos2) <- c(year = maxyear, month = length(pos2)/maxyear) + + timeseries <- apply(pos2, 1, function(y) {method(x[y], na.rm = na.rm)}) + timeseries <- as.array(timeseries) + + return(timeseries) +} + diff --git a/R/Trend.R b/R/Trend.R new file mode 100644 index 0000000..e970f89 --- /dev/null +++ b/R/Trend.R @@ -0,0 +1,182 @@ +#'Compute the trend +#' +#'Compute the linear trend or any degree of polynomial regression along the +#'forecast time. It returns the regression coefficients (including the intercept) +#'and the confidence intervals if needed. The detrended array is also provided.\cr +#'The confidence interval relies on the student-T distribution.\cr\cr +#' +#'@param data An numeric array including the dimension along which the trend +#' is computed. +#'@param time_dim A character string indicating the dimension along which to +#' compute the trend. The default value is 'sdate'. +#'@param interval A positive numeric indicating the unit length between two +#' points along 'time_dim' dimension. The default value is 1. +#'@param polydeg A positive integer indicating the degree of polynomial +#' regression. The default value is 1. +#'@param conf A logical value indicating whether to retrieve the confidence +#' intervals or not. The default value is TRUE. +#'@param conf.lev A numeric indicating the confidence level for the +#' regression computation. The default value is 0.95. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'\item{$trend}{ +#' A numeric array with the first dimension 'stats', followed by the same +#' dimensions as parameter 'data' except the 'time_dim' dimension. The length +#' of the 'stats' dimension should be \code{polydeg + 1}, containing the +#' regression coefficients from the lowest order (i.e., intercept) to the +#' highest degree. +#'} +#'\item{$conf.lower}{ +#' A numeric array with the first dimension 'stats', followed by the same +#' dimensions as parameter 'data' except the 'time_dim' dimension. The length +#' of the 'stats' dimension should be \code{polydeg + 1}, containing the +#' lower limit of the \code{conf.lev}\% confidence interval for all the +#' regression coefficients with the same order as \code{$trend}. Only present +#' \code{conf = TRUE}. +#'} +#'\item{$conf.upper}{ +#' A numeric array with the first dimension 'stats', followed by the same +#' dimensions as parameter 'data' except the 'time_dim' dimension. The length +#' of the 'stats' dimension should be \code{polydeg + 1}, containing the +#' upper limit of the \code{conf.lev}\% confidence interval for all the +#' regression coefficients with the same order as \code{$trend}. Only present +#' \code{conf = TRUE}. +#'} +#'\item{$detrended}{ +#' A numeric array with the same dimensions as paramter 'data', containing the +#' detrended values along the 'time_dim' dimension. +#'} +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-05 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to CRAN\cr +#'2.0 - 2017-02 (A. Hunter, \email{alasdair.hunter@@bsc.es}) - Adapt to veriApply() +#'3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'months_between_startdates <- 60 +#'trend <- Trend(sampleData$obs, polydeg = 2) +#' +#'@rdname Trend +#'@import multiApply +#'@export +Trend <- function(data, time_dim = 'sdate', interval = 1, polydeg = 1, + conf = TRUE, conf.lev = 0.95, ncores = NULL) { + + # Check inputs + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be a numeric array.") + } + if (is.null(dim(data))) { #is vector + dim(data) <- c(length(data)) + names(dim(data)) <- time_dim + } + if(any(is.null(names(dim(data))))| any(nchar(names(dim(data))) == 0)) { + stop("Parameter 'data' must have dimension names.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) > 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + ## interval + if (any(!is.numeric(interval) | interval <= 0 | length(interval) > 1)) { + stop("Parameter 'interval' must be a positive number.") + } + ## polydeg + if (!is.numeric(polydeg) | polydeg %% 1 != 0 | polydeg < 0 | + length(polydeg) > 1) { + stop("Parameter 'polydeg' must be a positive integer.") + } + ## conf + if (!is.logical(conf) | length(conf) > 1) { + stop("Parameter 'conf' must be one logical value.") + } + ## conf.lev + if (!is.numeric(conf.lev) | conf.lev < 0 | conf.lev > 1 | length(conf.lev) > 1) { + stop("Parameter 'conf.lev' must be a numeric number between 0 and 1.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + ############################### + # Calculate Trend + dim_names <- names(dim(data)) + + if (conf) { + output_dims <- list(trend = 'stats', conf.lower = 'stats', + conf.upper = 'stats', detrended = time_dim) + } else if (!conf) { + output_dims <- list(trend = 'stats', detrended = time_dim) + } + + + output <- Apply(list(data), + target_dims = time_dim, + fun = .Trend, + output_dims = output_dims, + time_dim = time_dim, interval = interval, + polydeg = polydeg, conf = conf, + conf.lev = conf.lev, + ncores = ncores) + + #output <- lapply(output, .reorder, time_dim = time_dim, dim_names = dim_names) + + return(output) +} + +.Trend <- function(x, time_dim = 'sdate', interval = 1, polydeg = 1, + conf = TRUE, conf.lev = 0.95) { + + mon <- seq(x) * interval + + # remove NAs for potential poly() + NApos <- 1:length(x) + NApos[which(is.na(x))] <- NA + x2 <- x[!is.na(NApos)] + mon2 <- mon[!is.na(NApos)] + + if (length(x2) > 0) { +# lm.out <- lm(x ~ mon, na.action = na.omit) + lm.out <- lm(x2 ~ poly(mon2, degree = polydeg, raw = TRUE), na.action = na.omit) + trend <- lm.out$coefficients #intercept, slope1, slope2,... + + if (conf) { + conf.lower <- confint(lm.out, level = conf.lev)[, 1] + conf.upper <- confint(lm.out, level = conf.lev)[, 2] + } + + detrended <- c() + detrended[is.na(x) == FALSE] <- x[is.na(x) == FALSE] - lm.out$fitted.values + } else { + trend <- rep(NA, polydeg + 1) + detrend <- NA + if (conf) { + conf.lower <- rep(NA, polydeg + 1) + conf.upper <- rep(NA, polydeg + 1) + } + } + + if (conf) { + return(list(trend = trend, conf.lower = conf.lower, conf.upper = conf.upper, + detrended = detrended)) + } else { + return(list(trend = trend, detrended = detrended)) + } + +} diff --git a/R/Utils.R b/R/Utils.R new file mode 100644 index 0000000..6bb8c51 --- /dev/null +++ b/R/Utils.R @@ -0,0 +1,1657 @@ +## Function to tell if a regexpr() match is a complete match to a specified name +.IsFullMatch <- function(x, name) { + ifelse(x > 0 && attributes(x)$match.length == nchar(name), TRUE, FALSE) +} + +.ConfigReplaceVariablesInString <- function(string, replace_values, allow_undefined_key_vars = FALSE) { + # This function replaces all the occurrences of a variable in a string by + # their corresponding string stored in the replace_values. + if (length(strsplit(string, "\\$")[[1]]) > 1) { + parts <- strsplit(string, "\\$")[[1]] + output <- "" + i <- 0 + for (part in parts) { + if (i %% 2 == 0) { + output <- paste(output, part, sep = "") + } else { + if (part %in% names(replace_values)) { + output <- paste(output, .ConfigReplaceVariablesInString(replace_values[[part]], replace_values, allow_undefined_key_vars), sep = "") + } else if (allow_undefined_key_vars) { + output <- paste0(output, "$", part, "$") + } else { + stop(paste('Error: The variable $', part, '$ was not defined in the configuration file.', sep = '')) + } + } + i <- i + 1 + } + output + } else { + string + } +} + +.KnownLonNames <- function() { + known_lon_names <- c('lon', 'longitude', 'x', 'i', 'nav_lon') +} + +.KnownLatNames <- function() { + known_lat_names <- c('lat', 'latitude', 'y', 'j', 'nav_lat') +} + +.t2nlatlon <- function(t) { + ## As seen in cdo's griddes.c: ntr2nlat() + nlats <- (t * 3 + 1) / 2 + if ((nlats > 0) && (nlats - trunc(nlats) >= 0.5)) { + nlats <- ceiling(nlats) + } else { + nlats <- round(nlats) + } + if (nlats %% 2 > 0) { + nlats <- nlats + 1 + } + ## As seen in cdo's griddes.c: compNlon(), and as specified in ECMWF + nlons <- 2 * nlats + keep_going <- TRUE + while (keep_going) { + n <- nlons + if (n %% 8 == 0) n <- trunc(n / 8) + while (n %% 6 == 0) n <- trunc(n / 6) + while (n %% 5 == 0) n <- trunc(n / 5) + while (n %% 4 == 0) n <- trunc(n / 4) + while (n %% 3 == 0) n <- trunc(n / 3) + if (n %% 2 == 0) n <- trunc(n / 2) + if (n <= 8) { + keep_going <- FALSE + } else { + nlons <- nlons + 2 + if (nlons > 9999) { + stop("Error: pick another gaussian grid truncation. It doesn't fulfill the standards to apply FFT.") + } + } + } + c(nlats, nlons) +} + +.nlat2t <- function(nlats) { + trunc((nlats * 2 - 1) / 3) +} + +.LoadDataFile <- function(work_piece, explore_dims = FALSE, silent = FALSE) { + # The purpose, working modes, inputs and outputs of this function are + # explained in ?LoadDataFile + #suppressPackageStartupMessages({library(ncdf4)}) + #suppressPackageStartupMessages({library(bigmemory)}) + #suppressPackageStartupMessages({library(plyr)}) + # Auxiliar function to convert array indices to lineal indices + arrayIndex2VectorIndex <- function(indices, dims) { + if (length(indices) > length(dims)) { + stop("Error: indices do not match dimensions in arrayIndex2VectorIndex.") + } + position <- 1 + dims <- rev(dims) + indices <- rev(indices) + for (i in 1:length(indices)) { + position <- position + (indices[i] - 1) * prod(dims[-c(1:i)]) + } + position + } + .t2nlatlon <- function(t) { + ## As seen in cdo's griddes.c: ntr2nlat() + nlats <- (t * 3 + 1) / 2 + if ((nlats > 0) && (nlats - trunc(nlats) >= 0.5)) { + nlats <- ceiling(nlats) + } else { + nlats <- round(nlats) + } + if (nlats %% 2 > 0) { + nlats <- nlats + 1 + } + ## As seen in cdo's griddes.c: compNlon(), and as specified in ECMWF + nlons <- 2 * nlats + keep_going <- TRUE + while (keep_going) { + n <- nlons + if (n %% 8 == 0) n <- trunc(n / 8) + while (n %% 6 == 0) n <- trunc(n / 6) + while (n %% 5 == 0) n <- trunc(n / 5) + while (n %% 4 == 0) n <- trunc(n / 4) + while (n %% 3 == 0) n <- trunc(n / 3) + if (n %% 2 == 0) n <- trunc(n / 2) + if (n <= 8) { + keep_going <- FALSE + } else { + nlons <- nlons + 2 + if (nlons > 9999) { + stop("Error: pick another gaussian grid truncation. It doesn't fulfill the standards to apply FFT.") + } + } + } + c(nlats, nlons) + } + + .nlat2t <- function(nlats) { + trunc((nlats * 2 - 1) / 3) + } + + found_file <- NULL + dims <- NULL + grid_name <- units <- var_long_name <- NULL + is_2d_var <- array_across_gw <- NULL + data_across_gw <- NULL + + filename <- work_piece[['filename']] + namevar <- work_piece[['namevar']] + output <- work_piece[['output']] + # The names of all data files in the directory of the repository that match + # the pattern are obtained. + if (length(grep("^http", filename)) > 0) { + is_url <- TRUE + files <- filename + ## TODO: Check that the user is not using shell globbing exps. + } else { + is_url <- FALSE + files <- Sys.glob(filename) + } + + # If we don't find any, we leave the flag 'found_file' with a NULL value. + if (length(files) > 0) { + # The first file that matches the pattern is chosen and read. + filename <- head(files, 1) + filein <- filename + found_file <- filename + mask <- work_piece[['mask']] + + if (!silent) { + if (explore_dims) { + .message(paste("Exploring dimensions...", filename)) + } + ##} else { + ## cat(paste("* Reading & processing data...", filename, '\n')) + ##} + } + + # We will fill in 'expected_dims' with the names of the expected dimensions of + # the data array we'll retrieve from the file. + expected_dims <- NULL + remap_needed <- FALSE + # But first we open the file and work out whether the requested variable is 2d + fnc <- nc_open(filein) + if (!(namevar %in% names(fnc$var))) { + stop(paste("Error: The variable", namevar, "is not defined in the file", filename)) + } + var_long_name <- fnc$var[[namevar]]$longname + units <- fnc$var[[namevar]]$units + file_dimnames <- unlist(lapply(fnc$var[[namevar]][['dim']], '[[', 'name')) + # The following two 'ifs' are to allow for 'lon'/'lat' by default, instead of + # 'longitude'/'latitude'. + if (!(work_piece[['dimnames']][['lon']] %in% file_dimnames) && + (work_piece[['dimnames']][['lon']] == 'longitude') && + ('lon' %in% file_dimnames)) { + work_piece[['dimnames']][['lon']] <- 'lon' + } + if (!(work_piece[['dimnames']][['lat']] %in% file_dimnames) && + (work_piece[['dimnames']][['lat']] == 'latitude') && + ('lat' %in% file_dimnames)) { + work_piece[['dimnames']][['lat']] <- 'lat' + } + if (is.null(work_piece[['is_2d_var']])) { + is_2d_var <- all(c(work_piece[['dimnames']][['lon']], + work_piece[['dimnames']][['lat']]) %in% + unlist(lapply(fnc$var[[namevar]][['dim']], + '[[', 'name'))) + } else { + is_2d_var <- work_piece[['is_2d_var']] + } + if ((is_2d_var || work_piece[['is_file_per_dataset']])) { + if (Sys.which("cdo")[[1]] == "") { + stop("Error: CDO libraries not available") + } + cdo_version <- as.numeric_version(strsplit(suppressWarnings(system2("cdo", args = '-V', stderr = TRUE))[[1]], ' ')[[1]][5]) + } + # If the variable to load is 2-d, we need to determine whether: + # - interpolation is needed + # - subsetting is requested + if (is_2d_var) { + ## We read the longitudes and latitudes from the file. + lon <- ncvar_get(fnc, work_piece[['dimnames']][['lon']]) + lat <- ncvar_get(fnc, work_piece[['dimnames']][['lat']]) + first_lon_in_original_file <- lon[1] + # If a common grid is requested or we are exploring the file dimensions + # we need to read the grid type and size of the file to finally work out the + # CDO grid name. + if (!is.null(work_piece[['grid']]) || explore_dims) { + # Here we read the grid type and its number of longitudes and latitudes + file_info <- system(paste('cdo -s griddes', filein, '2> /dev/null'), intern = TRUE) + grids_positions <- grep('# gridID', file_info) + if (length(grids_positions) < 1) { + stop("The grid should be defined in the files.") + } + grids_first_lines <- grids_positions + 2 + grids_last_lines <- c((grids_positions - 2)[-1], length(file_info)) + grids_info <- as.list(1:length(grids_positions)) + grids_info <- lapply(grids_info, function (x) file_info[grids_first_lines[x]:grids_last_lines[x]]) + grids_info <- lapply(grids_info, function (x) gsub(" *", " ", x)) + grids_info <- lapply(grids_info, function (x) gsub("^ | $", "", x)) + grids_info <- lapply(grids_info, function (x) unlist(strsplit(x, " | = "))) + grids_types <- unlist(lapply(grids_info, function (x) x[grep('gridtype', x) + 1])) + grids_matches <- unlist(lapply(grids_info, function (x) { + nlons <- if (length(grep('xsize', x)) > 0) { + as.numeric(x[grep('xsize', x) + 1]) + } else { + NA + } + nlats <- if (length(grep('ysize', x)) > 0) { + as.numeric(x[grep('ysize', x) + 1]) + } else { + NA + } + result <- FALSE + if (!any(is.na(c(nlons, nlats)))) { + if ((nlons == length(lon)) && + (nlats == length(lat))) { + result <- TRUE + } + } + result + })) + grids_matches <- grids_matches[which(grids_types %in% c('gaussian', 'lonlat'))] + grids_info <- grids_info[which(grids_types %in% c('gaussian', 'lonlat'))] + grids_types <- grids_types[which(grids_types %in% c('gaussian', 'lonlat'))] + if (length(grids_matches) == 0) { + stop("Error: Only 'gaussian' and 'lonlat' grids supported. See e.g: cdo sinfo ", filename) + } + if (sum(grids_matches) > 1) { + if ((all(grids_types[which(grids_matches)] == 'gaussian') || + all(grids_types[which(grids_matches)] == 'lonlat')) && + all(unlist(lapply(grids_info[which(grids_matches)], identical, + grids_info[which(grids_matches)][[1]])))) { + grid_type <- grids_types[which(grids_matches)][1] + } else { + stop("Error: Load() can't disambiguate: More than one lonlat/gaussian grids with the same size as the requested variable defined in ", filename) + } + } else if (sum(grids_matches) == 1) { + grid_type <- grids_types[which(grids_matches)] + } else { + stop("Unexpected error.") + } + grid_lons <- length(lon) + grid_lats <- length(lat) + # Convert to CDO grid name as seen in cdo's griddes.c: nlat2ntr() + if (grid_type == 'lonlat') { + grid_name <- paste0('r', grid_lons, 'x', grid_lats) + } else { + grid_name <- paste0('t', .nlat2t(grid_lats), 'grid') + } + } + # If a common grid is requested, we will also calculate its size which we will use + # later on. + if (!is.null(work_piece[['grid']])) { + # Now we calculate the common grid type and its lons and lats + if (length(grep('^t\\d{1,+}grid$', work_piece[['grid']])) > 0) { + common_grid_type <- 'gaussian' + common_grid_res <- as.numeric(strsplit(work_piece[['grid']], '[^0-9]{1,+}')[[1]][2]) + nlonlat <- .t2nlatlon(common_grid_res) + common_grid_lats <- nlonlat[1] + common_grid_lons <- nlonlat[2] + } else if (length(grep('^r\\d{1,+}x\\d{1,+}$', work_piece[['grid']])) > 0) { + common_grid_type <- 'lonlat' + common_grid_lons <- as.numeric(strsplit(work_piece[['grid']], '[^0-9]{1,+}')[[1]][2]) + common_grid_lats <- as.numeric(strsplit(work_piece[['grid']], '[^0-9]{1,+}')[[1]][3]) + } else { + stop("Error: Only supported grid types in parameter 'grid' are tgrid and rx") + } + } else { + ## If no 'grid' is specified, there is no common grid. + ## But these variables are filled in for consistency in the code. + common_grid_lons <- length(lon) + common_grid_lats <- length(lat) + } + first_common_grid_lon <- 0 + last_common_grid_lon <- 360 - 360/common_grid_lons + ## This is not true for gaussian grids or for some regular grids, but + ## is a safe estimation + first_common_grid_lat <- -90 + last_common_grid_lat <- 90 + # And finally determine whether interpolation is needed or not + remove_shift <- FALSE + if (!is.null(work_piece[['grid']])) { + if ((grid_lons != common_grid_lons) || + (grid_lats != common_grid_lats) || + (grid_type != common_grid_type) || + ((lon[1] != first_common_grid_lon) + && !work_piece[['single_dataset']])) { + if (grid_lons == common_grid_lons && grid_lats == common_grid_lats && + grid_type == common_grid_type && lon[1] != first_common_grid_lon && + !work_piece[['single_dataset']]) { + remove_shift <- TRUE + } + remap_needed <- TRUE + common_grid_name <- work_piece[['grid']] + } + } else if ((lon[1] != first_common_grid_lon) && explore_dims && + !work_piece[['single_dataset']]) { + remap_needed <- TRUE + common_grid_name <- grid_name + remove_shift <- TRUE + } + if (remap_needed && (work_piece[['remap']] == 'con') && + (cdo_version >= as.numeric_version('1.7.0'))) { + work_piece[['remap']] <- 'ycon' + } + if (remove_shift && !explore_dims) { + if (!is.null(work_piece[['progress_amount']])) { + cat("\n") + } + cat(paste0("! Warning: the dataset with index ", + tail(work_piece[['indices']], 1), " in '", + work_piece[['dataset_type']], "' doesn't start at longitude 0 and will be re-interpolated in order to align its longitudes with the standard CDO grids definable with the names 'tgrid' or 'rx', which are by definition starting at the longitude 0.\n")) + if (!is.null(mask)) { + cat(paste0("! Warning: a mask was provided for the dataset with index ", + tail(work_piece[['indices']], 1), " in '", + work_piece[['dataset_type']], "'. This dataset has been re-interpolated to align its longitudes to start at 0. You must re-interpolate the corresponding mask to align its longitudes to start at 0 as well, if you haven't done so yet. Running cdo remapcon,", common_grid_name, " original_mask_file.nc new_mask_file.nc will fix it.\n")) + } + } + if (remap_needed && (grid_lons < common_grid_lons || grid_lats < common_grid_lats)) { + if (!is.null(work_piece[['progress_amount']])) { + cat("\n") + } + if (!explore_dims) { + cat(paste0("! Warning: the dataset with index ", tail(work_piece[['indices']], 1), + " in '", work_piece[['dataset_type']], "' is originally on ", + "a grid coarser than the common grid and it has been ", + "extrapolated. Check the results carefully. It is ", + "recommended to specify as common grid the coarsest grid ", + "among all requested datasets via the parameter 'grid'.\n")) + } + } + # Now calculate if the user requests for a lonlat subset or for the + # entire field + lonmin <- work_piece[['lon_limits']][1] + lonmax <- work_piece[['lon_limits']][2] + latmin <- work_piece[['lat_limits']][1] + latmax <- work_piece[['lat_limits']][2] + lon_subsetting_requested <- FALSE + lonlat_subsetting_requested <- FALSE + if (lonmin <= lonmax) { + if ((lonmin > first_common_grid_lon) || (lonmax < last_common_grid_lon)) { + lon_subsetting_requested <- TRUE + } + } else { + if ((lonmin - lonmax) > 360/common_grid_lons) { + lon_subsetting_requested <- TRUE + } else { + gap_width <- floor(lonmin / (360/common_grid_lons)) - + floor(lonmax / (360/common_grid_lons)) + if (gap_width > 0) { + if (!(gap_width == 1 && (lonmin %% (360/common_grid_lons) == 0) && + (lonmax %% (360/common_grid_lons) == 0))) { + lon_subsetting_requested <- TRUE + } + } + } + } + if ((latmin > first_common_grid_lat) || (latmax < last_common_grid_lat) + || (lon_subsetting_requested)) { + lonlat_subsetting_requested <- TRUE + } + # Now that we know if subsetting was requested, we can say if final data + # will go across greenwich + if (lonmax < lonmin) { + data_across_gw <- TRUE + } else { + data_across_gw <- !lon_subsetting_requested + } + + # When remap is needed but no subsetting, the file is copied locally + # so that cdo works faster, and then interpolated. + # Otherwise the file is kept as is and the subset will have to be + # interpolated still. + if (!lonlat_subsetting_requested && remap_needed) { + nc_close(fnc) + filecopy <- tempfile(pattern = "load", fileext = ".nc") + file.copy(filein, filecopy) + filein <- tempfile(pattern = "loadRegridded", fileext = ".nc") + system(paste0("cdo -s remap", work_piece[['remap']], ",", + common_grid_name, + " -selname,", namevar, " ", filecopy, " ", filein, + " 2>/dev/null", sep = "")) + file.remove(filecopy) + work_piece[['dimnames']][['lon']] <- 'lon' + work_piece[['dimnames']][['lat']] <- 'lat' + fnc <- nc_open(filein) + lon <- ncvar_get(fnc, work_piece[['dimnames']][['lon']]) + lat <- ncvar_get(fnc, work_piece[['dimnames']][['lat']]) + } + + # Read and check also the mask + if (!is.null(mask)) { + ###mask_file <- tempfile(pattern = 'loadMask', fileext = '.nc') + if (is.list(mask)) { + if (!file.exists(mask[['path']])) { + stop(paste("Error: Couldn't find the mask file", mask[['path']])) + } + mask_file <- mask[['path']] + ###file.copy(work_piece[['mask']][['path']], mask_file) + fnc_mask <- nc_open(mask_file) + vars_in_mask <- sapply(fnc_mask$var, '[[', 'name') + if ('nc_var_name' %in% names(mask)) { + if (!(mask[['nc_var_name']] %in% + vars_in_mask)) { + stop(paste("Error: couldn't find variable", mask[['nc_var_name']], + "in the mask file", mask[['path']])) + } + } else { + if (length(vars_in_mask) != 1) { + stop(paste("Error: one and only one non-coordinate variable should be defined in the mask file", + mask[['path']], "if the component 'nc_var_name' is not specified. Currently found: ", + paste(vars_in_mask, collapse = ', '), ".")) + } else { + mask[['nc_var_name']] <- vars_in_mask + } + } + if (sum(fnc_mask$var[[mask[['nc_var_name']]]]$size > 1) != 2) { + stop(paste0("Error: the variable '", + mask[['nc_var_name']], + "' must be defined only over the dimensions '", + work_piece[['dimnames']][['lon']], "' and '", + work_piece[['dimnames']][['lat']], + "' in the mask file ", + mask[['path']])) + } + mask <- ncvar_get(fnc_mask, mask[['nc_var_name']], collapse_degen = TRUE) + nc_close(fnc_mask) + ### mask_lon <- ncvar_get(fnc_mask, work_piece[['dimnames']][['lon']]) + ### mask_lat <- ncvar_get(fnc_mask, work_piece[['dimnames']][['lat']]) + ###} else { + ### dim_longitudes <- ncdim_def(work_piece[['dimnames']][['lon']], "degrees_east", lon) + ### dim_latitudes <- ncdim_def(work_piece[['dimnames']][['lat']], "degrees_north", lat) + ### ncdf_var <- ncvar_def('LSM', "", list(dim_longitudes, dim_latitudes), NA, 'double') + ### fnc_mask <- nc_create(mask_file, list(ncdf_var)) + ### ncvar_put(fnc_mask, ncdf_var, work_piece[['mask']]) + ### nc_close(fnc_mask) + ### fnc_mask <- nc_open(mask_file) + ### work_piece[['mask']] <- list(path = mask_file, nc_var_name = 'LSM') + ### mask_lon <- lon + ### mask_lat <- lat + ###} + ###} + ### Now ready to check that the mask is right + ##if (!(lonlat_subsetting_requested && remap_needed)) { + ### if ((dim(mask)[2] != length(lon)) || (dim(mask)[1] != length(lat))) { + ### stop(paste("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is wrong. It must be on the common grid if the selected output type is 'lonlat', 'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on the grid of the corresponding dataset if the selected output type is 'areave' and no 'grid' has been specified. For more information check ?Load and see help on parameters 'grid', 'maskmod' and 'maskobs'.", sep = "")) + ### } + ###if (!(identical(mask_lon, lon) && identical(mask_lat, lat))) { + ### stop(paste0("Error: the longitudes and latitudes in the masks must be identical to the ones in the corresponding data files if output = 'areave' or, if the selected output is 'lon', 'lat' or 'lonlat', the longitudes in the mask file must start by 0 and the latitudes must be ordered from highest to lowest. See\n ", + ### work_piece[['mask']][['path']], " and ", filein)) + ###} + } + } + + lon_indices <- 1:length(lon) + if (!(lonlat_subsetting_requested && remap_needed)) { + lon[which(lon < 0)] <- lon[which(lon < 0)] + 360 + } + if (lonmax >= lonmin) { + lon_indices <- lon_indices[which(((lon %% 360) >= lonmin) & ((lon %% 360) <= lonmax))] + } else if (!remap_needed) { + lon_indices <- lon_indices[which(((lon %% 360) <= lonmax) | ((lon %% 360) >= lonmin))] + } + lat_indices <- which(lat >= latmin & lat <= latmax) + ## In most of the cases the latitudes are ordered from -90 to 90. + ## We will reorder them to be in the order from 90 to -90, so mostly + ## always the latitudes are reordered. + ## TODO: This could be avoided in future. + if (lat[1] < lat[length(lat)]) { + lat_indices <- lat_indices[length(lat_indices):1] + } + if (!is.null(mask) && !(lonlat_subsetting_requested && remap_needed)) { + if ((dim(mask)[1] != length(lon)) || (dim(mask)[2] != length(lat))) { + stop(paste("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is wrong. It must be on the common grid if the selected output type is 'lonlat', 'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on the grid of the corresponding dataset if the selected output type is 'areave' and no 'grid' has been specified. For more information check ?Load and see help on parameters 'grid', 'maskmod' and 'maskobs'.", sep = "")) + } + mask <- mask[lon_indices, lat_indices] + } + ## If the user requests subsetting, we must extend the lon and lat limits if possible + ## so that the interpolation after is done properly + maximum_extra_points <- work_piece[['remapcells']] + if (lonlat_subsetting_requested && remap_needed) { + if ((maximum_extra_points > (head(lon_indices, 1) - 1)) || + (maximum_extra_points > (length(lon) - tail(lon_indices, 1)))) { + ## if the requested number of points goes beyond the left or right + ## sides of the map, we need to take the entire map so that the + ## interpolation works properly + lon_indices <- 1:length(lon) + } else { + extra_points <- min(maximum_extra_points, head(lon_indices, 1) - 1) + if (extra_points > 0) { + lon_indices <- c((head(lon_indices, 1) - extra_points):(head(lon_indices, 1) - 1), lon_indices) + } + extra_points <- min(maximum_extra_points, length(lon) - tail(lon_indices, 1)) + if (extra_points > 0) { + lon_indices <- c(lon_indices, (tail(lon_indices, 1) + 1):(tail(lon_indices, 1) + extra_points)) + } + } + min_lat_ind <- min(lat_indices) + max_lat_ind <- max(lat_indices) + extra_points <- min(maximum_extra_points, min_lat_ind - 1) + if (extra_points > 0) { + if (lat[1] < tail(lat, 1)) { + lat_indices <- c(lat_indices, (min_lat_ind - 1):(min_lat_ind - extra_points)) + } else { + lat_indices <- c((min_lat_ind - extra_points):(min_lat_ind - 1), lat_indices) + } + } + extra_points <- min(maximum_extra_points, length(lat) - max_lat_ind) + if (extra_points > 0) { + if (lat[1] < tail(lat, 1)) { + lat_indices <- c((max_lat_ind + extra_points):(max_lat_ind + 1), lat_indices) + } else { + lat_indices <- c(lat_indices, (max_lat_ind + 1):(max_lat_ind + extra_points)) + } + } + } + lon <- lon[lon_indices] + lat <- lat[lat_indices] + expected_dims <- c(work_piece[['dimnames']][['lon']], + work_piece[['dimnames']][['lat']]) + } else { + lon <- 0 + lat <- 0 + } + # We keep on filling the expected dimensions + var_dimnames <- unlist(lapply(fnc$var[[namevar]][['dim']], '[[', 'name')) + nmemb <- nltime <- NULL + ## Sometimes CDO renames 'members' dimension to 'lev' + old_members_dimname <- NULL + if (('lev' %in% var_dimnames) && !(work_piece[['dimnames']][['member']] %in% var_dimnames)) { + old_members_dimname <- work_piece[['dimnames']][['member']] + work_piece[['dimnames']][['member']] <- 'lev' + } + if (work_piece[['dimnames']][['member']] %in% var_dimnames) { + nmemb <- fnc$var[[namevar]][['dim']][[match(work_piece[['dimnames']][['member']], var_dimnames)]]$len + expected_dims <- c(expected_dims, work_piece[['dimnames']][['member']]) + } else { + nmemb <- 1 + } + if (length(expected_dims) > 0) { + dim_matches <- match(expected_dims, var_dimnames) + if (any(is.na(dim_matches))) { + if (!is.null(old_members_dimname)) { + expected_dims[which(expected_dims == 'lev')] <- old_members_dimname + } + stop(paste("Error: the expected dimension(s)", + paste(expected_dims[which(is.na(dim_matches))], collapse = ', '), + "were not found in", filename)) + } + time_dimname <- var_dimnames[-dim_matches] + } else { + time_dimname <- var_dimnames + } + if (length(time_dimname) > 0) { + if (length(time_dimname) == 1) { + nltime <- fnc$var[[namevar]][['dim']][[match(time_dimname, var_dimnames)]]$len + expected_dims <- c(expected_dims, time_dimname) + dim_matches <- match(expected_dims, var_dimnames) + } else { + if (!is.null(old_members_dimname)) { + expected_dims[which(expected_dims == 'lev')] <- old_members_dimname + } + stop(paste("Error: the variable", namevar, + "is defined over more dimensions than the expected (", + paste(c(expected_dims, 'time'), collapse = ', '), + "). It could also be that the members, longitude or latitude dimensions are named incorrectly. In that case, either rename the dimensions in the file or adjust Load() to recognize the actual name with the parameter 'dimnames'. See file", filename)) + } + } else { + nltime <- 1 + } + + # Now we must retrieve the data from the file, but only the asked indices. + # So we build up the indices to retrieve. + # Longitudes or latitudes have been retrieved already. + if (explore_dims) { + # If we're exploring the file we only want one time step from one member, + # to regrid it and work out the number of longitudes and latitudes. + # We don't need more. + members <- 1 + ltimes_list <- list(c(1)) + } else { + # The data is arranged in the array 'tmp' with the dimensions in a + # common order: + # 1) Longitudes + # 2) Latitudes + # 3) Members (even if is not a file per member experiment) + # 4) Lead-times + if (work_piece[['is_file_per_dataset']]) { + time_indices <- 1:nltime + mons <- strsplit(system(paste('cdo showmon ', filein, + ' 2>/dev/null'), intern = TRUE), split = ' ') + years <- strsplit(system(paste('cdo showyear ', filein, + ' 2>/dev/null'), intern = TRUE), split = ' ') + mons <- as.numeric(mons[[1]][which(mons[[1]] != "")]) + years <- as.numeric(years[[1]][which(years[[1]] != "")]) + time_indices <- ts(time_indices, start = c(years[1], mons[1]), + end = c(years[length(years)], mons[length(mons)]), + frequency = 12) + ltimes_list <- list() + for (sdate in work_piece[['startdates']]) { + selected_time_indices <- window(time_indices, start = c(as.numeric( + substr(sdate, 1, 4)), as.numeric(substr(sdate, 5, 6))), + end = c(3000, 12), frequency = 12, extend = TRUE) + selected_time_indices <- selected_time_indices[work_piece[['leadtimes']]] + ltimes_list <- c(ltimes_list, list(selected_time_indices)) + } + } else { + ltimes <- work_piece[['leadtimes']] + #if (work_piece[['dataset_type']] == 'exp') { + ltimes_list <- list(ltimes[which(ltimes <= nltime)]) + #} + } + ## TODO: Put, when reading matrices, this kind of warnings + # if (nmember < nmemb) { + # cat("Warning: + members <- 1:work_piece[['nmember']] + members <- members[which(members <= nmemb)] + } + + # Now, for each list of leadtimes to load (usually only one list with all leadtimes), + # we'll join the indices and retrieve data + found_disordered_dims <- FALSE + for (ltimes in ltimes_list) { + if (is_2d_var) { + start <- c(min(lon_indices), min(lat_indices)) + end <- c(max(lon_indices), max(lat_indices)) + if (lonlat_subsetting_requested && remap_needed) { + subset_indices <- list(min(lon_indices):max(lon_indices) - min(lon_indices) + 1, + lat_indices - min(lat_indices) + 1) + dim_longitudes <- ncdim_def(work_piece[['dimnames']][['lon']], "degrees_east", lon) + dim_latitudes <- ncdim_def(work_piece[['dimnames']][['lat']], "degrees_north", lat) + ncdf_dims <- list(dim_longitudes, dim_latitudes) + } else { + subset_indices <- list(lon_indices - min(lon_indices) + 1, + lat_indices - min(lat_indices) + 1) + ncdf_dims <- list() + } + final_dims <- c(length(subset_indices[[1]]), length(subset_indices[[2]]), 1, 1) + } else { + start <- end <- c() + subset_indices <- list() + ncdf_dims <- list() + final_dims <- c(1, 1, 1, 1) + } + + if (work_piece[['dimnames']][['member']] %in% expected_dims) { + start <- c(start, head(members, 1)) + end <- c(end, tail(members, 1)) + subset_indices <- c(subset_indices, list(members - head(members, 1) + 1)) + dim_members <- ncdim_def(work_piece[['dimnames']][['member']], "", members) + ncdf_dims <- c(ncdf_dims, list(dim_members)) + final_dims[3] <- length(members) + } + if (time_dimname %in% expected_dims) { + if (any(!is.na(ltimes))) { + start <- c(start, head(ltimes[which(!is.na(ltimes))], 1)) + end <- c(end, tail(ltimes[which(!is.na(ltimes))], 1)) + subset_indices <- c(subset_indices, list(ltimes - head(ltimes[which(!is.na(ltimes))], 1) + 1)) + } else { + start <- c(start, NA) + end <- c(end, NA) + subset_indices <- c(subset_indices, list(ltimes)) + } + dim_time <- ncdim_def(time_dimname, "", 1:length(ltimes), unlim = TRUE) + ncdf_dims <- c(ncdf_dims, list(dim_time)) + final_dims[4] <- length(ltimes) + } + count <- end - start + 1 + start <- start[dim_matches] + count <- count[dim_matches] + subset_indices <- subset_indices[dim_matches] + # Now that we have the indices to retrieve, we retrieve the data + if (prod(final_dims) > 0) { + tmp <- take(ncvar_get(fnc, namevar, start, count, + collapse_degen = FALSE), + 1:length(subset_indices), subset_indices) + # The data is regridded if it corresponds to an atmospheric variable. When + # the chosen output type is 'areave' the data is not regridded to not + # waste computing time unless the user specified a common grid. + if (is_2d_var) { + ###if (!is.null(work_piece[['mask']]) && !(lonlat_subsetting_requested && remap_needed)) { + ### mask <- take(ncvar_get(fnc_mask, work_piece[['mask']][['nc_var_name']], + ### start[dim_matches[1:2]], count[dim_matches[1:2]], + ### collapse_degen = FALSE), 1:2, subset_indices[dim_matches[1:2]]) + ###} + if (lonlat_subsetting_requested && remap_needed) { + filein <- tempfile(pattern = "loadRegridded", fileext = ".nc") + filein2 <- tempfile(pattern = "loadRegridded2", fileext = ".nc") + ncdf_var <- ncvar_def(namevar, "", ncdf_dims[dim_matches], + fnc$var[[namevar]]$missval, + prec = if (fnc$var[[namevar]]$prec == 'int') { + 'integer' + } else { + fnc$var[[namevar]]$prec + }) + scale_factor <- ifelse(fnc$var[[namevar]]$hasScaleFact, fnc$var[[namevar]]$scaleFact, 1) + add_offset <- ifelse(fnc$var[[namevar]]$hasAddOffset, fnc$var[[namevar]]$addOffset, 0) + if (fnc$var[[namevar]]$hasScaleFact || fnc$var[[namevar]]$hasAddOffset) { + tmp <- (tmp - add_offset) / scale_factor + } + #nc_close(fnc) + fnc2 <- nc_create(filein2, list(ncdf_var)) + ncvar_put(fnc2, ncdf_var, tmp) + if (add_offset != 0) { + ncatt_put(fnc2, ncdf_var, 'add_offset', add_offset) + } + if (scale_factor != 1) { + ncatt_put(fnc2, ncdf_var, 'scale_factor', scale_factor) + } + nc_close(fnc2) + system(paste0("cdo -s -sellonlatbox,", if (lonmin > lonmax) { + "0,360," + } else { + paste0(lonmin, ",", lonmax, ",") + }, latmin, ",", latmax, + " -remap", work_piece[['remap']], ",", common_grid_name, + " ", filein2, " ", filein, " 2>/dev/null", sep = "")) + file.remove(filein2) + fnc2 <- nc_open(filein) + sub_lon <- ncvar_get(fnc2, 'lon') + sub_lat <- ncvar_get(fnc2, 'lat') + ## We read the longitudes and latitudes from the file. + ## In principle cdo should put in order the longitudes + ## and slice them properly unless data is across greenwich + sub_lon[which(sub_lon < 0)] <- sub_lon[which(sub_lon < 0)] + 360 + sub_lon_indices <- 1:length(sub_lon) + if (lonmax < lonmin) { + sub_lon_indices <- sub_lon_indices[which((sub_lon <= lonmax) | (sub_lon >= lonmin))] + } + sub_lat_indices <- 1:length(sub_lat) + ## In principle cdo should put in order the latitudes + if (sub_lat[1] < sub_lat[length(sub_lat)]) { + sub_lat_indices <- length(sub_lat):1 + } + final_dims[c(1, 2)] <- c(length(sub_lon_indices), length(sub_lat_indices)) + subset_indices[[dim_matches[1]]] <- sub_lon_indices + subset_indices[[dim_matches[2]]] <- sub_lat_indices + + tmp <- take(ncvar_get(fnc2, namevar, collapse_degen = FALSE), + 1:length(subset_indices), subset_indices) + + if (!is.null(mask)) { + ## We create a very simple 2d netcdf file that is then interpolated to the common + ## grid to know what are the lons and lats of our slice of data + mask_file <- tempfile(pattern = 'loadMask', fileext = '.nc') + mask_file_remap <- tempfile(pattern = 'loadMask', fileext = '.nc') + dim_longitudes <- ncdim_def(work_piece[['dimnames']][['lon']], "degrees_east", c(0, 360)) + dim_latitudes <- ncdim_def(work_piece[['dimnames']][['lat']], "degrees_north", c(-90, 90)) + ncdf_var <- ncvar_def('LSM', "", list(dim_longitudes, dim_latitudes), NA, 'double') + fnc_mask <- nc_create(mask_file, list(ncdf_var)) + ncvar_put(fnc_mask, ncdf_var, array(rep(0, 4), dim = c(2, 2))) + nc_close(fnc_mask) + system(paste0("cdo -s remap", work_piece[['remap']], ",", common_grid_name, + " ", mask_file, " ", mask_file_remap, " 2>/dev/null", sep = "")) + fnc_mask <- nc_open(mask_file_remap) + mask_lons <- ncvar_get(fnc_mask, 'lon') + mask_lats <- ncvar_get(fnc_mask, 'lat') + nc_close(fnc_mask) + file.remove(mask_file, mask_file_remap) + if ((dim(mask)[1] != common_grid_lons) || (dim(mask)[2] != common_grid_lats)) { + stop(paste("Error: the mask of the dataset with index ", tail(work_piece[['indices']], 1), " in '", work_piece[['dataset_type']], "' is wrong. It must be on the common grid if the selected output type is 'lonlat', 'lon' or 'lat', or 'areave' and 'grid' has been specified. It must be on the grid of the corresponding dataset if the selected output type is 'areave' and no 'grid' has been specified. For more information check ?Load and see help on parameters 'grid', 'maskmod' and 'maskobs'.", sep = "")) + } + mask_lons[which(mask_lons < 0)] <- mask_lons[which(mask_lons < 0)] + 360 + if (lonmax >= lonmin) { + mask_lon_indices <- which((mask_lons >= lonmin) & (mask_lons <= lonmax)) + } else { + mask_lon_indices <- which((mask_lons >= lonmin) | (mask_lons <= lonmax)) + } + mask_lat_indices <- which((mask_lats >= latmin) & (mask_lats <= latmax)) + if (sub_lat[1] < sub_lat[length(sub_lat)]) { + mask_lat_indices <- mask_lat_indices[length(mask_lat_indices):1] + } + mask <- mask[mask_lon_indices, mask_lat_indices] + } + sub_lon <- sub_lon[sub_lon_indices] + sub_lat <- sub_lat[sub_lat_indices] + ### nc_close(fnc_mask) + ### system(paste0("cdo -s -sellonlatbox,", if (lonmin > lonmax) { + ### "0,360," + ### } else { + ### paste0(lonmin, ",", lonmax, ",") + ### }, latmin, ",", latmax, + ### " -remap", work_piece[['remap']], ",", common_grid_name, + ###This is wrong: same files + ### " ", mask_file, " ", mask_file, " 2>/dev/null", sep = "")) + ### fnc_mask <- nc_open(mask_file) + ### mask <- take(ncvar_get(fnc_mask, work_piece[['mask']][['nc_var_name']], + ### collapse_degen = FALSE), 1:2, subset_indices[dim_matches[1:2]]) + ###} + } + } + if (!all(dim_matches == sort(dim_matches))) { + if (!found_disordered_dims && rev(work_piece[['indices']])[2] == 1 && rev(work_piece[['indices']])[3] == 1) { + found_disordered_dims <- TRUE + cat(paste0("! Warning: the dimensions for the variable ", namevar, " in the files of the experiment with index ", tail(work_piece[['indices']], 1), " are not in the optimal order for loading with Load(). The optimal order would be '", paste(expected_dims, collapse = ', '), "'. One of the files of the dataset is stored in ", filename)) + } + tmp <- aperm(tmp, dim_matches) + } + dim(tmp) <- final_dims + # If we are exploring the file we don't need to process and arrange + # the retrieved data. We only need to keep the dimension sizes. + if (is_2d_var && lonlat_subsetting_requested && remap_needed) { + final_lons <- sub_lon + final_lats <- sub_lat + } else { + final_lons <- lon + final_lats <- lat + } + if (explore_dims) { + if (work_piece[['is_file_per_member']]) { + ## TODO: When the exp_full_path contains asterisks and is file_per_member + ## members from different datasets may be accounted. + ## Also if one file member is missing the accounting will be wrong. + ## Should parse the file name and extract number of members. + if (is_url) { + nmemb <- NULL + } else { + nmemb <- length(files) + } + } + dims <- list(member = nmemb, ftime = nltime, lon = final_lons, lat = final_lats) + } else { + # If we are not exploring, then we have to process the retrieved data + if (is_2d_var) { + tmp <- apply(tmp, c(3, 4), function(x) { + # Disable of large values. + if (!is.na(work_piece[['var_limits']][2])) { + x[which(x > work_piece[['var_limits']][2])] <- NA + } + if (!is.na(work_piece[['var_limits']][1])) { + x[which(x < work_piece[['var_limits']][1])] <- NA + } + if (!is.null(mask)) { + x[which(mask < 0.5)] <- NA + } + + if (output == 'areave' || output == 'lon') { + weights <- InsertDim(cos(final_lats * pi / 180), 1, length(final_lons)) + weights[which(is.na(x))] <- NA + if (output == 'areave') { + weights <- weights / mean(weights, na.rm = TRUE) + mean(x * weights, na.rm = TRUE) + } else { + weights <- weights / InsertDim(Mean1Dim(weights, 2, narm = TRUE), 2, length(final_lats)) + Mean1Dim(x * weights, 2, narm = TRUE) + } + } else if (output == 'lat') { + Mean1Dim(x, 1, narm = TRUE) + } else if (output == 'lonlat') { + signif(x, 5) + } + }) + if (output == 'areave') { + dim(tmp) <- c(1, 1, final_dims[3:4]) + } else if (output == 'lon') { + dim(tmp) <- c(final_dims[1], 1, final_dims[3:4]) + } else if (output == 'lat') { + dim(tmp) <- c(1, final_dims[c(2, 3, 4)]) + } else if (output == 'lonlat') { + dim(tmp) <- final_dims + } + } + var_data <- attach.big.matrix(work_piece[['out_pointer']]) + if (work_piece[['dims']][['member']] > 1 && nmemb > 1 && + work_piece[['dims']][['ftime']] > 1 && + nltime < work_piece[['dims']][['ftime']]) { + work_piece[['indices']][2] <- work_piece[['indices']][2] - 1 + for (jmemb in members) { + work_piece[['indices']][2] <- work_piece[['indices']][2] + 1 + out_position <- arrayIndex2VectorIndex(work_piece[['indices']], work_piece[['dims']]) + out_indices <- out_position:(out_position + length(tmp[, , jmemb, ]) - 1) + var_data[out_indices] <- as.vector(tmp[, , jmemb, ]) + } + work_piece[['indices']][2] <- work_piece[['indices']][2] - tail(members, 1) + 1 + } else { + out_position <- arrayIndex2VectorIndex(work_piece[['indices']], work_piece[['dims']]) + out_indices <- out_position:(out_position + length(tmp) - 1) + a <- aperm(tmp, c(1, 2, 4, 3)) + as.vector(a) + var_data[out_indices] <- as.vector(aperm(tmp, c(1, 2, 4, 3))) + } + work_piece[['indices']][3] <- work_piece[['indices']][3] + 1 + } + } + } + nc_close(fnc) + if (is_2d_var) { + if (remap_needed) { + array_across_gw <- FALSE + file.remove(filein) + ###if (!is.null(mask) && lonlat_subsetting_requested) { + ### file.remove(mask_file) + ###} + } else { + if (first_lon_in_original_file < 0) { + array_across_gw <- data_across_gw + } else { + array_across_gw <- FALSE + } + } + } + } + if (explore_dims) { + list(dims = dims, is_2d_var = is_2d_var, grid = grid_name, + units = units, var_long_name = var_long_name, + data_across_gw = data_across_gw, array_across_gw = array_across_gw) + } else { + ###if (!silent && !is.null(progress_connection) && !is.null(work_piece[['progress_amount']])) { + ### foobar <- writeBin(work_piece[['progress_amount']], progress_connection) + ###} + if (!silent && !is.null(work_piece[['progress_amount']])) { + message(paste0(work_piece[['progress_amount']]), appendLF = FALSE) + } + found_file + } +} + +.LoadSampleData <- function(var, exp = NULL, obs = NULL, sdates, + nmember = NULL, nmemberobs = NULL, + nleadtime = NULL, leadtimemin = 1, + leadtimemax = NULL, storefreq = 'monthly', + sampleperiod = 1, lonmin = 0, lonmax = 360, + latmin = -90, latmax = 90, output = 'areave', + method = 'conservative', grid = NULL, + maskmod = vector("list", 15), + maskobs = vector("list", 15), + configfile = NULL, suffixexp = NULL, + suffixobs = NULL, varmin = NULL, varmax = NULL, + silent = FALSE, nprocs = NULL) { + ## This function loads and selects sample data stored in sampleMap and + ## sampleTimeSeries and is used in the examples instead of Load() so as + ## to avoid nco and cdo system calls and computation time in the stage + ## of running examples in the CHECK process on CRAN. + selected_start_dates <- match(sdates, c('19851101', '19901101', '19951101', + '20001101', '20051101')) + start_dates_position <- 3 + lead_times_position <- 4 + + if (output == 'lonlat') { + sampleData <- s2dverification::sampleMap + if (is.null(leadtimemax)) { + leadtimemax <- dim(sampleData$mod)[lead_times_position] + } + selected_lead_times <- leadtimemin:leadtimemax + + dataOut <- sampleData + dataOut$mod <- sampleData$mod[, , selected_start_dates, selected_lead_times, , ] + dataOut$obs <- sampleData$obs[, , selected_start_dates, selected_lead_times, , ] + } + else if (output == 'areave') { + sampleData <- s2dverification::sampleTimeSeries + if (is.null(leadtimemax)) { + leadtimemax <- dim(sampleData$mod)[lead_times_position] + } + selected_lead_times <- leadtimemin:leadtimemax + + dataOut <- sampleData + dataOut$mod <- sampleData$mod[, , selected_start_dates, selected_lead_times] + dataOut$obs <- sampleData$obs[, , selected_start_dates, selected_lead_times] + } + + dims_out <- dim(sampleData$mod) + dims_out[start_dates_position] <- length(selected_start_dates) + dims_out[lead_times_position] <- length(selected_lead_times) + dim(dataOut$mod) <- dims_out + + dims_out <- dim(sampleData$obs) + dims_out[start_dates_position] <- length(selected_start_dates) + dims_out[lead_times_position] <- length(selected_lead_times) + dim(dataOut$obs) <- dims_out + + invisible(list(mod = dataOut$mod, obs = dataOut$obs, + lat = dataOut$lat, lon = dataOut$lon)) +} + +.ConfigGetDatasetInfo <- function(matching_entries, table_name) { + # This function obtains the information of a dataset and variable pair, + # applying all the entries that match in the configuration file. + if (table_name == 'experiments') { + id <- 'EXP' + } else { + id <- 'OBS' + } + defaults <- c(paste0('$DEFAULT_', id, '_MAIN_PATH$'), paste0('$DEFAULT_', id, '_FILE_PATH$'), '$DEFAULT_NC_VAR_NAME$', '$DEFAULT_SUFFIX$', '$DEFAULT_VAR_MIN$', '$DEFAULT_VAR_MAX$') + info <- NULL + + for (entry in matching_entries) { + if (is.null(info)) { + info <- entry[-1:-2] + info[which(info == '*')] <- defaults[which(info == '*')] + } else { + info[which(entry[-1:-2] != '*')] <- entry[-1:-2][which(entry[-1:-2] != '*')] + } + } + + info <- as.list(info) + names(info) <- c('main_path', 'file_path', 'nc_var_name', 'suffix', 'var_min', 'var_max') + info +} + +.ReplaceGlobExpressions <- function(path_with_globs, actual_path, + replace_values, tags_to_keep, + dataset_name, permissive) { + # The goal of this function is to replace the shell globbing expressions in + # a path pattern (that may contain shell globbing expressions and Load() + # tags) by the corresponding part of the real existing path. + # What is done actually is to replace all the values of the tags in the + # actual path by the corresponding $TAG$ + # + # It takes mainly two inputs. The path with expressions and tags, e.g.: + # /data/experiments/*/$EXP_NAME$/$VAR_NAME$/$VAR_NAME$_*$START_DATE$*.nc + # and a complete known path to one of the matching files, e.g.: + # /data/experiments/ecearth/i00k/tos/tos_fc0-1_19901101_199011-199110.nc + # and it returns the path pattern but without shell globbing expressions: + # /data/experiments/ecearth/$EXP_NAME$/$VAR_NAME$/$VAR_NAME$_fc0-1_$START_DATE$_199011-199110.nc + # + # To do that, it needs also as inputs the list of replace values (the + # association of each tag to their value). + # + # All the tags not present in the parameter tags_to_keep will be repalced. + # + # Not all cases can be resolved with the implemented algorithm. In an + # unsolvable case a warning is given and one possible guess is returned. + # + # In some cases it is interesting to replace only the expressions in the + # path to the file, but not the ones in the file name itself. To keep the + # expressions in the file name, the parameter permissive can be set to + # TRUE. To replace all the expressions it can be set to FALSE. + clean <- function(x) { + if (nchar(x) > 0) { + x <- gsub('\\\\', '', x) + x <- gsub('\\^', '', x) + x <- gsub('\\$', '', x) + x <- unname(sapply(strsplit(x, '[',fixed = TRUE)[[1]], function(y) gsub('.*]', '.', y))) + do.call(paste0, as.list(x)) + } else { + x + } + } + + strReverse <- function(x) sapply(lapply(strsplit(x, NULL), rev), paste, collapse = "") + + if (permissive) { + actual_path_chunks <- strsplit(actual_path, '/')[[1]] + actual_path <- paste(actual_path_chunks[-length(actual_path_chunks)], collapse = '/') + file_name <- tail(actual_path_chunks, 1) + if (length(actual_path_chunks) > 1) { + file_name <- paste0('/', file_name) + } + path_with_globs_chunks <- strsplit(path_with_globs, '/')[[1]] + path_with_globs <- paste(path_with_globs_chunks[-length(path_with_globs_chunks)], + collapse = '/') + path_with_globs <- .ConfigReplaceVariablesInString(path_with_globs, replace_values) + file_name_with_globs <- tail(path_with_globs_chunks, 1) + if (length(path_with_globs_chunks) > 1) { + file_name_with_globs <- paste0('/', file_name_with_globs) + } + right_known <- head(strsplit(file_name_with_globs, '*', fixed = TRUE)[[1]], 1) + right_known_no_tags <- .ConfigReplaceVariablesInString(right_known, replace_values) + path_with_globs_rx <- utils::glob2rx(paste0(path_with_globs, right_known_no_tags)) + match <- regexpr(gsub('$', '', path_with_globs_rx, fixed = TRUE), paste0(actual_path, file_name)) + if (match != 1) { + stop("Incorrect parameters to replace glob expressions. The path with expressions does not match the actual path.") + } + if (attr(match, 'match.length') - nchar(right_known_no_tags) < nchar(actual_path)) { + path_with_globs <- paste0(path_with_globs, right_known_no_tags, '*') + file_name_with_globs <- sub(right_known, '/*', file_name_with_globs) + } + } + path_with_globs_rx <- utils::glob2rx(path_with_globs) + values_to_replace <- c() + tags_to_replace_starts <- c() + tags_to_replace_ends <- c() + give_warning <- FALSE + for (tag in tags_to_keep) { + matches <- gregexpr(paste0('$', tag, '$'), path_with_globs_rx, fixed = TRUE)[[1]] + lengths <- attr(matches, 'match.length') + if (!(length(matches) == 1 && matches[1] == -1)) { + for (i in 1:length(matches)) { + left <- NULL + if (matches[i] > 1) { + left <- .ConfigReplaceVariablesInString(substr(path_with_globs_rx, 1, matches[i] - 1), replace_values) + left_known <- strReverse(head(strsplit(strReverse(left), strReverse('.*'), fixed = TRUE)[[1]], 1)) + } + right <- NULL + if ((matches[i] + lengths[i] - 1) < nchar(path_with_globs_rx)) { + right <- .ConfigReplaceVariablesInString(substr(path_with_globs_rx, matches[i] + lengths[i], nchar(path_with_globs_rx)), replace_values) + right_known <- head(strsplit(right, '.*', fixed = TRUE)[[1]], 1) + } + final_match <- NULL + match_limits <- NULL + if (!is.null(left)) { + left_match <- regexpr(paste0(left, replace_values[[tag]], right_known), actual_path) + match_len <- attr(left_match, 'match.length') + left_match_limits <- c(left_match + match_len - 1 - nchar(clean(right_known)) - nchar(replace_values[[tag]]) + 1, + left_match + match_len - 1 - nchar(clean(right_known))) + if (!(left_match < 1)) { + match_limits <- left_match_limits + } + } + right_match <- NULL + if (!is.null(right)) { + right_match <- regexpr(paste0(left_known, replace_values[[tag]], right), actual_path) + match_len <- attr(right_match, 'match.length') + right_match_limits <- c(right_match + nchar(clean(left_known)), + right_match + nchar(clean(left_known)) + nchar(replace_values[[tag]]) - 1) + if (is.null(match_limits) && !(right_match < 1)) { + match_limits <- right_match_limits + } + } + if (!is.null(right_match) && !is.null(left_match)) { + if (!identical(right_match_limits, left_match_limits)) { + give_warning <- TRUE + } + } + if (is.null(match_limits)) { + stop("Too complex path pattern specified for ", dataset_name, + ". Specify a simpler path pattern for this dataset.") + } + values_to_replace <- c(values_to_replace, tag) + tags_to_replace_starts <- c(tags_to_replace_starts, match_limits[1]) + tags_to_replace_ends <- c(tags_to_replace_ends, match_limits[2]) + } + } + } + + if (length(tags_to_replace_starts) > 0) { + reorder <- sort(tags_to_replace_starts, index.return = TRUE) + tags_to_replace_starts <- reorder$x + values_to_replace <- values_to_replace[reorder$ix] + tags_to_replace_ends <- tags_to_replace_ends[reorder$ix] + while (length(values_to_replace) > 0) { + actual_path <- paste0(substr(actual_path, 1, head(tags_to_replace_starts, 1) - 1), + '$', head(values_to_replace, 1), '$', + substr(actual_path, head(tags_to_replace_ends, 1) + 1, nchar(actual_path))) + extra_chars <- nchar(head(values_to_replace, 1)) + 2 - (head(tags_to_replace_ends, 1) - head(tags_to_replace_starts, 1) + 1) + values_to_replace <- values_to_replace[-1] + tags_to_replace_starts <- tags_to_replace_starts[-1] + tags_to_replace_ends <- tags_to_replace_ends[-1] + tags_to_replace_starts <- tags_to_replace_starts + extra_chars + tags_to_replace_ends <- tags_to_replace_ends + extra_chars + } + } + + if (give_warning) { + .warning(paste0("Too complex path pattern specified for ", dataset_name, + ". Double check carefully the '$Files' fetched for this dataset or specify a simpler path pattern.")) + } + + if (permissive) { + paste0(actual_path, file_name_with_globs) + } else { + actual_path + } +} + +.FindTagValue <- function(path_with_globs_and_tag, actual_path, tag) { + tag <- paste0('\\$', tag, '\\$') + path_with_globs_and_tag <- paste0('^', path_with_globs_and_tag, '$') + parts <- strsplit(path_with_globs_and_tag, '*', fixed = TRUE)[[1]] + parts <- as.list(parts[grep(tag, parts)]) + longest_couples <- c() + pos_longest_couples <- c() + found_value <- NULL + for (i in 1:length(parts)) { + parts[[i]] <- strsplit(parts[[i]], tag)[[1]] + if (length(parts[[i]]) == 1) { + parts[[i]] <- c(parts[[i]], '') + } + len_parts <- sapply(parts[[i]], nchar) + len_couples <- len_parts[-length(len_parts)] + len_parts[2:length(len_parts)] + pos_longest_couples <- c(pos_longest_couples, which.max(len_couples)) + longest_couples <- c(longest_couples, max(len_couples)) + } + chosen_part <- which.max(longest_couples) + parts[[chosen_part]] <- parts[[chosen_part]][pos_longest_couples[chosen_part]:(pos_longest_couples[chosen_part] + 1)] + if (nchar(parts[[chosen_part]][1]) >= nchar(parts[[chosen_part]][2])) { + if (nchar(parts[[chosen_part]][1]) > 0) { + matches <- gregexpr(parts[[chosen_part]][1], actual_path)[[1]] + if (length(matches) == 1) { + match_left <- matches + actual_path <- substr(actual_path, match_left + attr(match_left, 'match.length'), nchar(actual_path)) + } + } + if (nchar(parts[[chosen_part]][2]) > 0) { + matches <- gregexpr(parts[[chosen_part]][2], actual_path)[[1]] + if (length(matches) == 1) { + match_right <- matches + found_value <- substr(actual_path, 0, match_right - 1) + } + } + } else { + if (nchar(parts[[chosen_part]][2]) > 0) { + matches <- gregexpr(parts[[chosen_part]][2], actual_path)[[1]] + if (length(matches) == 1) { + match_right <- matches + actual_path <- substr(actual_path, 0, match_right - 1) + } + } + if (nchar(parts[[chosen_part]][1]) > 0) { + matches <- gregexpr(parts[[chosen_part]][1], actual_path)[[1]] + if (length(matches) == 1) { + match_left <- matches + found_value <- substr(actual_path, match_left + attr(match_left, 'match.length'), nchar(actual_path)) + } + } + } + found_value +} + +.FilterUserGraphicArgs <- function(excludedArgs, ...) { + # This function filter the extra graphical parameters passed by the user in + # a plot function, excluding the ones that the plot function uses by default. + # Each plot function has a different set of arguments that are not allowed to + # be modified. + args <- list(...) + userArgs <- list() + for (name in names(args)) { + if ((name != "") & !is.element(name, excludedArgs)) { + # If the argument has a name and it is not in the list of excluded + # arguments, then it is added to the list that will be used + userArgs[[name]] <- args[[name]] + } else { + .warning(paste0("the argument '", name, "' can not be + modified and the new value will be ignored")) + } + } + userArgs +} + +.SelectDevice <- function(fileout, width, height, units, res) { + # This function is used in the plot functions to check the extension of the + # files where the graphics will be stored and select the right R device to + # save them. + # If the vector of filenames ('fileout') has files with different + # extensions, then it will only accept the first one, changing all the rest + # of the filenames to use that extension. + + # We extract the extension of the filenames: '.png', '.pdf', ... + ext <- regmatches(fileout, regexpr("\\.[a-zA-Z0-9]*$", fileout)) + + if (length(ext) != 0) { + # If there is an extension specified, select the correct device + ## units of width and height set to accept inches + if (ext[1] == ".png") { + saveToFile <- function(fileout) { + png(filename = fileout, width = width, height = height, res = res, units = units) + } + } else if (ext[1] == ".jpeg") { + saveToFile <- function(fileout) { + jpeg(filename = fileout, width = width, height = height, res = res, units = units) + } + } else if (ext[1] %in% c(".eps", ".ps")) { + saveToFile <- function(fileout) { + postscript(file = fileout, width = width, height = height) + } + } else if (ext[1] == ".pdf") { + saveToFile <- function(fileout) { + pdf(file = fileout, width = width, height = height) + } + } else if (ext[1] == ".svg") { + saveToFile <- function(fileout) { + svg(filename = fileout, width = width, height = height) + } + } else if (ext[1] == ".bmp") { + saveToFile <- function(fileout) { + bmp(filename = fileout, width = width, height = height, res = res, units = units) + } + } else if (ext[1] == ".tiff") { + saveToFile <- function(fileout) { + tiff(filename = fileout, width = width, height = height, res = res, units = units) + } + } else { + .warning("file extension not supported, it will be used '.eps' by default.") + ## In case there is only one filename + fileout[1] <- sub("\\.[a-zA-Z0-9]*$", ".eps", fileout[1]) + ext[1] <- ".eps" + saveToFile <- function(fileout) { + postscript(file = fileout, width = width, height = height) + } + } + # Change filenames when necessary + if (any(ext != ext[1])) { + .warning(paste0("some extensions of the filenames provided in 'fileout' are not ", ext[1],". The extensions are being converted to ", ext[1], ".")) + fileout <- sub("\\.[a-zA-Z0-9]*$", ext[1], fileout) + } + } else { + # Default filenames when there is no specification + .warning("there are no extensions specified in the filenames, default to '.eps'") + fileout <- paste0(fileout, ".eps") + saveToFile <- postscript + } + + # return the correct function with the graphical device, and the correct + # filenames + list(fun = saveToFile, files = fileout) +} + +.message <- function(...) { + # Function to use the 'message' R function with our custom settings + # Default: new line at end of message, indent to 0, exdent to 3, + # collapse to \n* + args <- list(...) + + ## In case we need to specify message arguments + if (!is.null(args[["appendLF"]])) { + appendLF <- args[["appendLF"]] + } else { + ## Default value in message function + appendLF <- TRUE + } + if (!is.null(args[["domain"]])) { + domain <- args[["domain"]] + } else { + ## Default value in message function + domain <- NULL + } + args[["appendLF"]] <- NULL + args[["domain"]] <- NULL + + ## To modify strwrap indent and exdent arguments + if (!is.null(args[["indent"]])) { + indent <- args[["indent"]] + } else { + indent <- 0 + } + if (!is.null(args[["exdent"]])) { + exdent <- args[["exdent"]] + } else { + exdent <- 3 + } + args[["indent"]] <- NULL + args[["exdent"]] <- NULL + + ## To modify paste collapse argument + if (!is.null(args[["collapse"]])) { + collapse <- args[["collapse"]] + } else { + collapse <- "\n*" + } + args[["collapse"]] <- NULL + + ## Message tag + if (!is.null(args[["tag"]])) { + tag <- args[["tag"]] + } else { + tag <- "* " + } + args[["tag"]] <- NULL + + message(paste0(tag, paste(strwrap( + args, indent = indent, exdent = exdent + ), collapse = collapse)), appendLF = appendLF, domain = domain) +} + +.warning <- function(...) { + # Function to use the 'warning' R function with our custom settings + # Default: no call information, indent to 0, exdent to 3, + # collapse to \n + args <- list(...) + + ## In case we need to specify warning arguments + if (!is.null(args[["call."]])) { + call <- args[["call."]] + } else { + ## Default: don't show info about the call where the warning came up + call <- FALSE + } + if (!is.null(args[["immediate."]])) { + immediate <- args[["immediate."]] + } else { + ## Default value in warning function + immediate <- FALSE + } + if (!is.null(args[["noBreaks."]])) { + noBreaks <- args[["noBreaks."]] + } else { + ## Default value warning function + noBreaks <- FALSE + } + if (!is.null(args[["domain"]])) { + domain <- args[["domain"]] + } else { + ## Default value warning function + domain <- NULL + } + args[["call."]] <- NULL + args[["immediate."]] <- NULL + args[["noBreaks."]] <- NULL + args[["domain"]] <- NULL + + ## To modify strwrap indent and exdent arguments + if (!is.null(args[["indent"]])) { + indent <- args[["indent"]] + } else { + indent <- 0 + } + if (!is.null(args[["exdent"]])) { + exdent <- args[["exdent"]] + } else { + exdent <- 3 + } + args[["indent"]] <- NULL + args[["exdent"]] <- NULL + + ## To modify paste collapse argument + if (!is.null(args[["collapse"]])) { + collapse <- args[["collapse"]] + } else { + collapse <- "\n!" + } + args[["collapse"]] <- NULL + + ## Warning tag + if (!is.null(args[["tag"]])) { + tag <- args[["tag"]] + } else { + tag <- "! Warning: " + } + args[["tag"]] <- NULL + + warning(paste0(tag, paste(strwrap( + args, indent = indent, exdent = exdent + ), collapse = collapse)), call. = call, immediate. = immediate, + noBreaks. = noBreaks, domain = domain) +} + +.IsColor <- function(x) { + res <- try(col2rgb(x), silent = TRUE) + return(!"try-error" %in% class(res)) +} + +# This function switches to a specified figure at position (row, col) in a layout. +# This overcomes the bug in par(mfg = ...). However the mode par(new = TRUE) is +# activated, i.e., all drawn elements will be superimposed. Additionally, after +# using this function, the automatical pointing to the next figure in the layout +# will be spoiled: once the last figure in the layout is drawn, the pointer won't +# move to the first figure in the layout. +# Only figures with numbers other than 0 (when creating the layout) will be +# accessible. +# Inputs: either row and col, or n and mat +.SwitchToFigure <- function(row = NULL, col = NULL, n = NULL, mat = NULL) { + if (!is.null(n) && !is.null(mat)) { + if (!is.numeric(n) || length(n) != 1) { + stop("Parameter 'n' must be a single numeric value.") + } + n <- round(n) + if (!is.array(mat)) { + stop("Parameter 'mat' must be an array.") + } + target <- which(mat == n, arr.ind = TRUE)[1, ] + row <- target[1] + col <- target[2] + } else if (!is.null(row) && !is.null(col)) { + if (!is.numeric(row) || length(row) != 1) { + stop("Parameter 'row' must be a single numeric value.") + } + row <- round(row) + if (!is.numeric(col) || length(col) != 1) { + stop("Parameter 'col' must be a single numeric value.") + } + col <- round(col) + } else { + stop("Either 'row' and 'col' or 'n' and 'mat' must be provided.") + } + next_attempt <- c(row, col) + par(mfg = next_attempt) + i <- 1 + layout_size <- par('mfrow') + layout_cells <- matrix(1:prod(layout_size), layout_size[1], layout_size[2], + byrow = TRUE) + while (any((par('mfg')[1:2] != c(row, col)))) { + next_attempt <- which(layout_cells == i, arr.ind = TRUE)[1, ] + par(mfg = next_attempt) + i <- i + 1 + if (i > prod(layout_size)) { + stop("Figure not accessible.") + } + } + plot(0, type = 'n', axes = FALSE, ann = FALSE) + par(mfg = next_attempt) +} + +# Function to permute arrays of non-atomic elements (e.g. POSIXct) +.aperm2 <- function(x, new_order) { + old_dims <- dim(x) + attr_bk <- attributes(x) + if ('dim' %in% names(attr_bk)) { + attr_bk[['dim']] <- NULL + } + if (is.numeric(x)) { + x <- aperm(x, new_order) + } else { + y <- array(1:length(x), dim = dim(x)) + y <- aperm(y, new_order) + x <- x[as.vector(y)] + } + dim(x) <- old_dims[new_order] + attributes(x) <- c(attributes(x), attr_bk) + x +} + +# This function is a helper for the function .MergeArrays. +# It expects as inputs two named numeric vectors, and it extends them +# with dimensions of length 1 until an ordered common dimension +# format is reached. +# The first output is dims1 extended with 1s. +# The second output is dims2 extended with 1s. +# The third output is a merged dimension vector. If dimensions with +# the same name are found in the two inputs, and they have a different +# length, the maximum is taken. +.MergeArrayDims <- function(dims1, dims2) { + new_dims1 <- c() + new_dims2 <- c() + while (length(dims1) > 0) { + if (names(dims1)[1] %in% names(dims2)) { + pos <- which(names(dims2) == names(dims1)[1]) + dims_to_add <- rep(1, pos - 1) + if (length(dims_to_add) > 0) { + names(dims_to_add) <- names(dims2[1:(pos - 1)]) + } + new_dims1 <- c(new_dims1, dims_to_add, dims1[1]) + new_dims2 <- c(new_dims2, dims2[1:pos]) + dims1 <- dims1[-1] + dims2 <- dims2[-c(1:pos)] + } else { + new_dims1 <- c(new_dims1, dims1[1]) + new_dims2 <- c(new_dims2, 1) + names(new_dims2)[length(new_dims2)] <- names(dims1)[1] + dims1 <- dims1[-1] + } + } + if (length(dims2) > 0) { + dims_to_add <- rep(1, length(dims2)) + names(dims_to_add) <- names(dims2) + new_dims1 <- c(new_dims1, dims_to_add) + new_dims2 <- c(new_dims2, dims2) + } + list(new_dims1, new_dims2, pmax(new_dims1, new_dims2)) +} + +# This function takes two named arrays and merges them, filling with +# NA where needed. +# dim(array1) +# 'b' 'c' 'e' 'f' +# 1 3 7 9 +# dim(array2) +# 'a' 'b' 'd' 'f' 'g' +# 2 3 5 9 11 +# dim(.MergeArrays(array1, array2, 'b')) +# 'a' 'b' 'c' 'e' 'd' 'f' 'g' +# 2 4 3 7 5 9 11 +.MergeArrays <- function(array1, array2, along) { + if (!(is.null(array1) || is.null(array2))) { + if (!(identical(names(dim(array1)), names(dim(array2))) && + identical(dim(array1)[-which(names(dim(array1)) == along)], + dim(array2)[-which(names(dim(array2)) == along)]))) { + new_dims <- .MergeArrayDims(dim(array1), dim(array2)) + dim(array1) <- new_dims[[1]] + dim(array2) <- new_dims[[2]] + for (j in 1:length(dim(array1))) { + if (names(dim(array1))[j] != along) { + if (dim(array1)[j] != dim(array2)[j]) { + if (which.max(c(dim(array1)[j], dim(array2)[j])) == 1) { + na_array_dims <- dim(array2) + na_array_dims[j] <- dim(array1)[j] - dim(array2)[j] + na_array <- array(dim = na_array_dims) + array2 <- abind(array2, na_array, along = j) + names(dim(array2)) <- names(na_array_dims) + } else { + na_array_dims <- dim(array1) + na_array_dims[j] <- dim(array2)[j] - dim(array1)[j] + na_array <- array(dim = na_array_dims) + array1 <- abind(array1, na_array, along = j) + names(dim(array1)) <- names(na_array_dims) + } + } + } + } + } + if (!(along %in% names(dim(array2)))) { + stop("The dimension specified in 'along' is not present in the ", + "provided arrays.") + } + array1 <- abind(array1, array2, along = which(names(dim(array1)) == along)) + names(dim(array1)) <- names(dim(array2)) + } else if (is.null(array1)) { + array1 <- array2 + } + array1 +} + +# only can be used in Trend(). Needs generalization or be replaced by other function. +.reorder <- function(output, time_dim, dim_names) { + # Add dim name back + if (is.null(dim(output))) { + dim(output) <- c(stats = length(output)) + } else { #is an array + if (length(dim(output)) == 1) { + if (!is.null(names(dim(output)))) { + dim(output) <- c(1, dim(output)) + names(dim(output))[1] <- time_dim + } else { + names(dim(output)) <- time_dim + } + } else { # more than one dim + if (names(dim(output))[1] != "") { + dim(output) <- c(1, dim(output)) + names(dim(output))[1] <- time_dim + } else { #regular case + names(dim(output))[1] <- time_dim + } + } + } + # reorder + pos <- match(dim_names, names(dim(output))) + output <- aperm(output, pos) + names(dim(output)) <- dim_names + names(dim(output))[names(dim(output)) == time_dim] <- 'stats' + return(output) +} + diff --git a/man/Clim.Rd b/man/Clim.Rd new file mode 100644 index 0000000..b17b2ee --- /dev/null +++ b/man/Clim.Rd @@ -0,0 +1,92 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Clim.R +\name{Clim} +\alias{Clim} +\title{Compute Bias Corrected Climatologies} +\usage{ +Clim(exp, obs, time_dim = "sdate", dat_dim = c("dataset", "member"), + method = "clim", ftime_dim = "ftime", memb_dim = "member", + memb = TRUE, na.rm = TRUE, ncores = NULL) +} +\arguments{ +\item{exp}{A named numeric array of experimental data, with at least two +dimensions 'time_dim' and 'dat_dim'.} + +\item{obs}{A named numeric array of observational data, same dimensions as +parameter 'exp' except along 'dat_dim'.} + +\item{time_dim}{A character string indicating the name of dimension along +which the climatologies are computed. The default value is 'sdate'.} + +\item{dat_dim}{A character vector indicating the name of the dataset and +member dimensions. If data at one startdate (i.e., 'time_dim') are not +complete along 'dat_dim', this startdate along 'dat_dim' will be discarded. +The default value is "c('dataset', 'member')".} + +\item{method}{A character string indicating the method to be used. The +options include 'clim', 'kharin', and 'NDV'. The default value is 'clim'.} + +\item{ftime_dim}{A character string indicating the name of forecast time +dimension. Only used when method = 'NDV'. The default value is 'ftime'.} + +\item{memb_dim}{A character string indicating the name of the member +dimension. Only used when parameter 'memb' is FALSE. It must be one element +in 'dat_dim'. The default value is 'member'.} + +\item{memb}{A logical value indicating whether to remain 'memb_dim' dimension +(TRUE) or do ensemble mean over 'memb_dim' (FALSE). The default value is TRUE.} + +\item{na.rm}{A logical value indicating whether to remove NA values along +'time_dim' when calculating climatology (TRUE) or return NA if there is NA +along 'time_dim' (FALSE). The default value is TRUE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list of 2: +\item{$clim_exp}{ + A numeric array with the same dimensions as parameter 'exp' but + dimension 'time_dim' is moved to the first position. If parameter 'method' + is 'clim', dimension 'time_dim' is removed. If parameter 'memb' is FALSE, + dimension 'memb_dim' is also removed. +} +\item{$clim_obs}{ + A numeric array with the same dimensions as parameter 'exp' + except dimension 'time_dim' is removed. If parameter 'memb' is FALSE, + dimension 'memb_dim' is also removed. +} +} +\description{ +This function computes per-pair climatologies for the experimental +and observational data using one of the following methods: +\enumerate{ + \item{per-pair method (Garcia-Serrano and Doblas-Reyes, CD, 2012)} + \item{Kharin method (Karin et al, GRL, 2012)} + \item{Fuckar method (Fuckar et al, GRL, 2014)} +} +Per-pair climatology means that only the startdates covered by the +whole experiments/observational dataset will be used. In other words, the +startdates which are not all available along 'dat_dim' dimension of both +the 'exp' and 'obs' are excluded when computing the climatologies. +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) +clim2 <- Clim(sampleData$mod, sampleData$obs, method = 'kharin', memb = F) +\donttest{ +PlotClim(clim$clim_exp, clim$clim_obs, + toptitle = paste('sea surface temperature climatologies'), + ytitle = 'K', monini = 11, listexp = c('CMIP5 IC3'), + listobs = c('ERSST'), biglab = FALSE, fileout = 'tos_clim.eps') +} +} +\author{ +History:\cr + 0.9 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr + 1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN + 3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adopt multiApply feature +} +\keyword{datagen} + diff --git a/man/Corr.Rd b/man/Corr.Rd new file mode 100644 index 0000000..72edd2c --- /dev/null +++ b/man/Corr.Rd @@ -0,0 +1,105 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Corr.R +\name{Corr} +\alias{Corr} +\title{Compute the correlation coefficient between an array of forecast and their corresponding observation} +\usage{ +Corr(exp, obs, time_dim = "sdate", memb_dim = "member", comp_dim = NULL, + limits = NULL, method = "pearson", pval = TRUE, conf = TRUE, + conf.lev = 0.95, ncores = NULL) +} +\arguments{ +\item{exp}{A named numeric array of experimental data, with at least two +dimensions 'time_dim' and 'memb_dim'.} + +\item{obs}{A named numeric array of observational data, same dimensions as +parameter 'exp' except along memb_dim.} + +\item{time_dim}{A character string indicating the name of dimension along +which the correlations are computed. The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of member (nobs/nexp) +dimension. The default value is 'member'.} + +\item{comp_dim}{A character string indicating the name of dimension along which +the data is taken into account only if it is complete. The default value +is NULL.} + +\item{limits}{A vector of two integers indicating the range along comp_dim to +be completed. The default is c(1, length(comp_dim dimension)).} + +\item{method}{A character string indicating the type of correlation: +'pearson', 'spearman', or 'kendall'. The default value is 'pearson'.} + +\item{pval}{A logical value indicating whether to compute or not the p-value +of the test Ho: Corr = 0. The default value is TRUE.} + +\item{conf}{A logical value indicating whether to retrieve the confidence +intervals or not. The default value is TRUE.} + +\item{conf.lev}{A numeric indicating the confidence level for the +regression computation. The default value is 0.95.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list containing the numeric arrays with dimension:\cr + c(nexp, nobs, all other dimensions of exp except time_dim).\cr +nexp is the number of experiment (i.e., memb_dim in exp), and nobs is the +number of observation (i.e., memb_dim in obs).\cr +\item{$corr}{ + The correlation coefficient. +} +\item{$p.val}{ + The p-value. Only present if \code{pval = TRUE}. +} +\item{$conf.lower}{ + The lower confidence interval. Only present if \code{conf = TRUE}. +} +\item{$conf.upper}{ + The upper confidence interval. Only present if \code{conf = TRUE}. +} +} +\description{ +Calculate the correlation coefficient (Pearson, Kendall or Spearman) for +an array of forecast and an array of observation. The correlations are +computed along time_dim, the startdate dimension. If comp_dim is given, +the correlations are computed only if data along the comp_dim dimension are +complete between limits[1] and limits[2], i.e., there is no NA between +limits[1] and limits[2]. This option can be activated if the user wants to +account only for the forecasts which the corresponding observations are +available at all leadtimes.\cr +The confidence interval is computed by the Fisher transformation and the +significance level relies on an one-sided student-T distribution.\cr +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +runmean_months <- 12 +dim_to_smooth <- 4 +# Smooth along lead-times +smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +leadtimes_per_startdate <- 60 +corr <- Corr(smooth_ano_exp, + smooth_ano_obs, + comp_dim = 'ftime', #Discard start dates which contain any NA ftime + limits = c(ceiling((runmean_months + 1) / 2), + leadtimes_per_startdate - floor(runmean_months / 2))) + +} +\author{ +History:\cr +0.1 - 2011-04 (V. Guemas, \email{vguemas@bsc.es}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to R CRAN\cr +1.1 - 2014-10 (M. Menegoz, \email{martin.menegoz@bsc.es}) - Adding conf.lev argument\cr +1.2 - 2015-03 (L.P. Caron, \email{louis-philippe.caron@bsc.es}) - Adding method argument\cr +1.3 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapted to veriApply() +3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +} +\keyword{datagen} + diff --git a/man/Eno.Rd b/man/Eno.Rd new file mode 100644 index 0000000..53f2813 --- /dev/null +++ b/man/Eno.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Eno.R +\name{Eno} +\alias{Eno} +\title{Compute effective sample size with classical method} +\usage{ +Eno(data, time_dim = "sdate", na.action = na.pass, ncores = NULL) +} +\arguments{ +\item{data}{A numeric array with named dimensions.} + +\item{time_dim}{A function indicating the dimension along which to compute +the effective sample size. The default value is 'sdate'.} + +\item{na.action}{A function. It can be na.pass (missing values are allowed) +or na.fail (no missing values are allowed). See details in stats::acf(). +The default value is na.pass.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +An array with the same dimension as parameter 'data' except the + time_dim dimension, which is removed after the computation. The array + indicates the number of effective sample along time_dim. +} +\description{ +Compute the number of effective samples along one dimension of an array. This +effective number of independent observations can be used in +statistical/inference tests.\cr +The calculation is based on eno function from Caio Coelho from rclim.txt. +} +\examples{ +set.seed(1) +data <- array(rnorm(800), dim = c(dataset = 1, member = 2, sdate = 4, + ftime = 4, lat = 10, lon = 10)) +na <- floor(runif(40, min = 1, max = 800)) +data[na] <- NA +res <- Eno(data) + +} +\author{ +History:\cr +0.1 - 2011-05 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN +3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Adopt multiApply feature +} +\keyword{datagen} + diff --git a/man/InsertDim.Rd b/man/InsertDim.Rd new file mode 100644 index 0000000..1f6aac6 --- /dev/null +++ b/man/InsertDim.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/InsertDim.R +\name{InsertDim} +\alias{InsertDim} +\title{Add a named dimension to an array} +\usage{ +InsertDim(data, posdim, lendim, name = NULL, ncores = NULL) +} +\arguments{ +\item{data}{An array to which the additional dimension to be added.} + +\item{posdim}{An integer indicating the position of the new dimension.} + +\item{lendim}{An integer indicating the length of the new dimension.} + +\item{name}{A character string indicating the name for the new dimension. +The default value is NULL.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +An array as parameter 'data' but with the added named dimension. +} +\description{ +Insert an extra dimension into an array at position 'posdim' with length +'lendim'. The array repeats along the new dimension. +} +\examples{ +a <- array(rnorm(15), dim = c(a = 3, b = 1, c = 5, d = 1)) +res <- InsertDim(InsertDim(a, posdim = 2, lendim = 1, name = 'e'), 4, c(f = 2)) +dim(res) + +} +\author{ +History:\cr +0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN\cr +1.1 - 2015-03 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Improvements +3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Modify with multiApply +} +\keyword{datagen} + diff --git a/man/RMS.Rd b/man/RMS.Rd new file mode 100644 index 0000000..91aa9b0 --- /dev/null +++ b/man/RMS.Rd @@ -0,0 +1,93 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/RMS.R +\name{RMS} +\alias{RMS} +\title{Compute root mean square error} +\usage{ +RMS(exp, obs, time_dim = "sdate", memb_dim = "member", comp_dim = NULL, + limits = NULL, conf = TRUE, conf.lev = 0.95, ncores = NULL) +} +\arguments{ +\item{exp}{A named numeric array of experimental data, with at least two +dimensions 'time_dim' and 'memb_dim'.} + +\item{obs}{A named numeric array of observational data, same dimensions as +parameter 'exp' except along memb_dim.} + +\item{time_dim}{A character string indicating the name of dimension along +which the correlations are computed. The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of member (nobs/nexp) +dimension. The default value is 'member'.} + +\item{comp_dim}{A character string indicating the name of dimension along which +the data is taken into account only if it is complete. The default value +is NULL.} + +\item{limits}{A vector of two integers indicating the range along comp_dim to +be completed. The default value is c(1, length(comp_dim dimension)).} + +\item{conf}{A logical value indicating whether to retrieve the confidence +intervals or not. The default value is TRUE.} + +\item{conf.lev}{A numeric indicating the confidence level for the +regression computation. The default value is 0.95.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list containing the numeric arrays with dimension:\cr + c(nexp, nobs, all other dimensions of exp except time_dim).\cr +nexp is the number of experiment (i.e., memb_dim in exp), and nobs is the +number of observation (i.e., memb_dim in obs).\cr +\item{$rms}{ + The root mean square error. +} +\item{$conf.lower}{ + The lower confidence interval. Only present if \code{conf = TRUE}. +} +\item{$conf.upper}{ + The upper confidence interval. Only present if \code{conf = TRUE}. +} +} +\description{ +Compute the root mean square error for an array of forecasts and an array of +observations. The RMSEs are computed along time_dim, the dimension which +corresponds to the startdate dimension. If comp_dim is given, the RMSEs are +computed only if data along the comp_dim dimension are complete between +limits[1] and limits[2], i.e. there are no NAs between limits[1] and +limits[2]. This option can be activated if the user wishes to account only +for the forecasts for which the corresponding observations are available at +all leadtimes.\cr +The confidence interval is computed by the chi2 distribution.\cr +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +runmean_months <- 12 +dim_to_smooth <- 4 # Smooth along lead-times +smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +dim_to_mean <- 2 # Mean along members +# Discard start-dates for which some leadtimes are missing +leadtimes_per_startdate <- 60 +rms <- RMS(smooth_ano_exp, + smooth_ano_obs, + comp_dim = 'ftime', + limits = c(ceiling((runmean_months + 1) / 2), + leadtimes_per_startdate - floor(runmean_months / 2))) + +} +\author{ +History:\cr +0.1 - 2011-05 (V. Guemas, \email{vguemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens2@ic3.cat}) - Formatting to R CRAN\cr +1.1 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapted to veriApply() +3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +} +\keyword{datagen} + diff --git a/man/RMSSS.Rd b/man/RMSSS.Rd new file mode 100644 index 0000000..240a746 --- /dev/null +++ b/man/RMSSS.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/RMSSS.R +\name{RMSSS} +\alias{RMSSS} +\title{Compute root mean square error skill score} +\usage{ +RMSSS(exp, obs, time_dim = "sdate", memb_dim = "member", pval = TRUE, + ncores = NULL) +} +\arguments{ +\item{exp}{A named numeric array of experimental data which contains at least +two dimensions for memb_dim and time_dim.} + +\item{obs}{A named numeric array of observational data which contains at least +two dimensions for memb_dim and time_dim. The dimensions should be the same +as paramter 'exp' except the length of 'memb_dim' dimension. The order of +dimension can be different.} + +\item{time_dim}{A character string indicating the name of dimension along +which the RMSSS are computed. The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of member (nobs/nexp) +dimension. The default value is 'member'.} + +\item{pval}{A logical value indicating whether to compute or not the p-value +of the test Ho: RMSSS = 0. If pval = TRUE, the insignificant RMSSS will +return NA. The default value is TRUE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list containing the numeric arrays with dimension:\cr + c(nexp, nobs, all other dimensions of exp except time_dim).\cr +nexp is the number of experiment (i.e., memb_dim in exp), and nobs is the +number of observation (i.e., memb_dim in obs).\cr +\item{$rmsss}{ + The root mean square error skill score. +} +\item{$p.val}{ + The p-value. Only present if \code{pval = TRUE}. +} +} +\description{ +Compute the root mean square error skill score (RMSSS) between an array of +forecast 'exp' and an array of observation 'obs'. The two arrays should +have the same dimensions except along memb_dim, where the length can be +different, with the number of experiments/models (nexp) and the number of +observational datasets (nobs).\cr +RMSSS computes the root mean square error skill score of each jexp in 1:nexp +against each jobs in 1:nobs which gives nexp * nobs RMSSS for each other +grid point of the array.\cr +The RMSSS are computed along the time_dim dimension which should corresponds +to the startdate dimension.\cr +The p-value is optionally provided by an one-sided Fisher test.\cr +} +\examples{ +set.seed(1) +exp <- array(rnorm(15), dim = c(dat = 1, time = 3, member = 5)) +set.seed(2) +obs <- array(rnorm(6), dim = c(time = 3, member = 2, dat = 1)) +res <- RMSSS(exp, obs, time_dim = 'time') + +} +\author{ +History:\cr +0.1 - 2012-04 (V. Guemas, \email{vguemas@bsc.es}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to R CRAN\cr +1.1 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapted to veriApply() +3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Adopt multiApply feature +} +\keyword{datagen} + diff --git a/man/Regression.Rd b/man/Regression.Rd new file mode 100644 index 0000000..f6a28a2 --- /dev/null +++ b/man/Regression.Rd @@ -0,0 +1,101 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Regression.R +\name{Regression} +\alias{Regression} +\title{Compute the regression of an array on another along one dimension.} +\usage{ +Regression(datay, datax, time_dim = "sdate", formula = y ~ x, pval = TRUE, + conf = TRUE, conf.lev = 0.95, na.action = na.omit, ncores = NULL) +} +\arguments{ +\item{datay}{An numeric array as predictand including the dimension along +which the regression is computed.} + +\item{datax}{An numeric array as predictor. The dimension should be identical +as parameter 'datay'.} + +\item{time_dim}{A character string indicating the dimension along which to +compute the regression.} + +\item{formula}{An object of class "formula" (see function \code{link[stats]{lm}}).} + +\item{pval}{A logical value indicating whether to retrieve the p-value +or not. The default value is TRUE.} + +\item{conf}{A logical value indicating whether to retrieve the confidence +intervals or not. The default value is TRUE.} + +\item{conf.lev}{A numeric indicating the confidence level for the +regression computation. The default value is 0.95.} + +\item{na.action}{A function or an integer. A function (e.g., na.omit, +na.exclude, na.fail, na.pass) indicates what should happen when the data +contain NAs. A numeric indicates the maximum number of NA position (it +counts as long as one of datay and datax is NA) allowed for compute +regression. The default value is na.omit-} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. Default value is NULL.} +} +\value{ +\item{$regression}{ + A numeric array with same dimensions as parameter 'datay' and 'datax' except + the 'time_dim' dimension, which is replaced by a 'stats' dimension containing + the regression coefficients from the lowest order (i.e., intercept) to + the highest degree. The length of the 'stats' dimension should be + \code{polydeg + 1}. +} +\item{$conf.lower}{ + A numeric array with same dimensions as parameter 'daty' and 'datax' except + the 'time_dim' dimension, which is replaced by a 'stats' dimension containing + the lower value of the \code{siglev}\% confidence interval for all + the regression coefficients with the same order as $regression. The length + of 'stats' dimension should be \code{polydeg + 1}. Only present if + \code{conf = TRUE}. +} +\item{$conf.upper}{ + A numeric array with same dimensions as parameter 'daty' and 'datax' except + the 'time_dim' dimension, which is replaced by a 'stats' dimension containing + the upper value of the \code{siglev}\% confidence interval for all + the regression coefficients with the same order as $regression. The length + of 'stats' dimension should be \code{polydeg + 1}. Only present if + \code{conf = TRUE}. +} +\item{$p.val}{ + A numeric array with same dimensions as parameter 'daty' and 'datax' except + the 'time_dim' dimension, The array contains the p-value. +} +\item{$filtered}{ + A numeric array with the same dimension as paramter 'datay' and 'datax', + the filtered datay from the regression onto datax along the 'time_dim' + dimension. +} +} +\description{ +Compute the regression of the array 'datay' on the array 'datax' along the +'time_dim' dimension by least square fitting (default) or self-defined model. +The function provides the slope of the regression, the intercept, and the +associated p-value and confidence interval. The filtered datay from the +regression onto datax is also provided.\cr +The p-value relies on the F distribution, and the confidence interval relies +on the student-T distribution. +} +\examples{ +# Load sample data as in Load() example: +example(Load) +datay <- sampleData$mod +datax <- sampleData$obs +datay <- Subset(datay, 'member', 2) +res1 <- Regression(datay, datax, formula = y~poly(x, 2, raw = TRUE)) +res2 <- Regression(datay, datax, conf.lev = 0.9) + +} +\author{ +History:\cr +0.1 - 2013-05 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +2.0 - 2019-10 (N. Perez-Zanon, \email{nuria.perez@bsc.es}) - Formatting to multiApply +3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +} +\keyword{datagen} + diff --git a/man/Season.Rd b/man/Season.Rd new file mode 100644 index 0000000..fad6f22 --- /dev/null +++ b/man/Season.Rd @@ -0,0 +1,56 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Season.R +\name{Season} +\alias{Season} +\title{Compute seasonal mean} +\usage{ +Season(data, time_dim = "sdate", monini, moninf, monsup, method = mean, + na.rm = TRUE, ncores = NULL) +} +\arguments{ +\item{data}{A named numeric array with at least one dimension 'time_dim'.} + +\item{time_dim}{A character string indicating the name of dimension along +which the seasonal means are computed. The default value is 'sdate'.} + +\item{monini}{An integer indicating what the first month of the time series is. +It can be from 1 to 12.} + +\item{moninf}{An integer indicating the starting month of the seasonal mean. +It can be from 1 to 12.} + +\item{monsup}{An integer indicating the end month of the seasonal mean. It +can be from 1 to 12.} + +\item{method}{An R function to be applied for seasonal calculation. For +example, 'sum' can be used for total precipitation. The default value is mean.} + +\item{na.rm}{A logical value indicating whether to remove NA values along +'time_dim' when calculating climatology (TRUE) or return NA if there is NA +along 'time_dim' (FALSE). The default value is TRUE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +An array with the same dimensions as data except along the 'time_dim' + dimension, of which the length changes to the number of seasons. +} +\description{ +Compute the seasonal mean (or other methods) on monthly time series along +one dimension of a named multi-dimensional arrays. Partial season is not +accounted. +} +\examples{ +set.seed(1) +dat1 <- array(rnorm(144*3), dim = c(member = 2, sdate = 12*3, ftime = 2, lon = 3)) +res <- Season(data = dat1, monini = 1, moninf = 1, monsup = 2) +res <- Season(data = dat1, monini = 10, moninf = 12, monsup = 2) +dat2 <- dat1 +set.seed(2) +na <- floor(runif(30, min = 1, max = 144*3)) +dat2[na] <- NA +res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2) +res <- Season(data = dat2, monini = 3, moninf = 1, monsup = 2, na.rm = FALSE) +} + diff --git a/man/Trend.Rd b/man/Trend.Rd new file mode 100644 index 0000000..f058009 --- /dev/null +++ b/man/Trend.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Trend.R +\name{Trend} +\alias{Trend} +\title{Compute the trend} +\usage{ +Trend(data, time_dim = "sdate", interval = 1, polydeg = 1, conf = TRUE, + conf.lev = 0.95, ncores = NULL) +} +\arguments{ +\item{data}{An numeric array including the dimension along which the trend +is computed.} + +\item{time_dim}{A character string indicating the dimension along which to +compute the trend. The default value is 'sdate'.} + +\item{interval}{A positive numeric indicating the unit length between two +points along 'time_dim' dimension. The default value is 1.} + +\item{polydeg}{A positive integer indicating the degree of polynomial +regression. The default value is 1.} + +\item{conf}{A logical value indicating whether to retrieve the confidence +intervals or not. The default value is TRUE.} + +\item{conf.lev}{A numeric indicating the confidence level for the +regression computation. The default value is 0.95.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +\item{$trend}{ + A numeric array with the first dimension 'stats', followed by the same + dimensions as parameter 'data' except the 'time_dim' dimension. The length + of the 'stats' dimension should be \code{polydeg + 1}, containing the + regression coefficients from the lowest order (i.e., intercept) to the + highest degree. +} +\item{$conf.lower}{ + A numeric array with the first dimension 'stats', followed by the same + dimensions as parameter 'data' except the 'time_dim' dimension. The length + of the 'stats' dimension should be \code{polydeg + 1}, containing the + lower limit of the \code{conf.lev}\% confidence interval for all the + regression coefficients with the same order as \code{$trend}. Only present + \code{conf = TRUE}. +} +\item{$conf.upper}{ + A numeric array with the first dimension 'stats', followed by the same + dimensions as parameter 'data' except the 'time_dim' dimension. The length + of the 'stats' dimension should be \code{polydeg + 1}, containing the + upper limit of the \code{conf.lev}\% confidence interval for all the + regression coefficients with the same order as \code{$trend}. Only present + \code{conf = TRUE}. +} +\item{$detrended}{ + A numeric array with the same dimensions as paramter 'data', containing the + detrended values along the 'time_dim' dimension. +} +} +\description{ +Compute the linear trend or any degree of polynomial regression along the +forecast time. It returns the regression coefficients (including the intercept) +and the confidence intervals if needed. The detrended array is also provided.\cr +The confidence interval relies on the student-T distribution.\cr\cr +} +\examples{ +# Load sample data as in Load() example: +example(Load) +months_between_startdates <- 60 +trend <- Trend(sampleData$obs, polydeg = 2) + +} +\author{ +History:\cr +0.1 - 2011-05 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN\cr +2.0 - 2017-02 (A. Hunter, \email{alasdair.hunter@bsc.es}) - Adapt to veriApply() +3.0 - 2019-12 (A. Ho, \email{an.ho@bsc.es}) - Adapt multiApply feature +} +\keyword{datagen} + -- GitLab From 3cee2a5f694db842ccc06185654d9e2ca1ac93f4 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 31 Jan 2020 12:21:34 +0100 Subject: [PATCH 2/2] Copy s2dverification functions no need to + Apply --- R/AnimateMap.R | 296 +++++ R/CDORemap.R | 1033 +++++++++++++++++ R/ColorBar.R | 600 ++++++++++ R/LeapYear.R | 36 + R/Load.R | 2321 +++++++++++++++++++++++++++++++++++++++ R/Plot2VarsVsLTime.R | 258 +++++ R/PlotACC.R | 251 +++++ R/PlotAno.R | 304 +++++ R/PlotBoxWhisker.R | 243 ++++ R/PlotClim.R | 214 ++++ R/PlotEquiMap.R | 874 +++++++++++++++ R/PlotLayout.R | 667 +++++++++++ R/PlotMatrix.R | 227 ++++ R/PlotSection.R | 172 +++ R/PlotStereoMap.R | 563 ++++++++++ R/PlotVsLTime.R | 271 +++++ R/ToyModel.R | 203 ++++ R/clim.palette.R | 58 + man/AnimateMap.Rd | 197 ++++ man/CDORemap.Rd | 229 ++++ man/ColorBar.Rd | 188 ++++ man/LeapYear.Rd | 30 + man/Load.Rd | 886 +++++++++++++++ man/Plot2VarsVsLTime.Rd | 123 +++ man/PlotACC.Rd | 125 +++ man/PlotAno.Rd | 112 ++ man/PlotBoxWhisker.Rd | 134 +++ man/PlotClim.Rd | 90 ++ man/PlotEquiMap.Rd | 291 +++++ man/PlotLayout.Rd | 252 +++++ man/PlotMatrix.Rd | 96 ++ man/PlotSection.Rd | 78 ++ man/PlotStereoMap.Rd | 195 ++++ man/PlotVsLTime.Rd | 136 +++ man/ToyModel.Rd | 128 +++ man/clim.palette.Rd | 38 + 36 files changed, 11919 insertions(+) create mode 100644 R/AnimateMap.R create mode 100644 R/CDORemap.R create mode 100644 R/ColorBar.R create mode 100644 R/LeapYear.R create mode 100644 R/Load.R create mode 100644 R/Plot2VarsVsLTime.R create mode 100644 R/PlotACC.R create mode 100644 R/PlotAno.R create mode 100644 R/PlotBoxWhisker.R create mode 100644 R/PlotClim.R create mode 100644 R/PlotEquiMap.R create mode 100644 R/PlotLayout.R create mode 100644 R/PlotMatrix.R create mode 100644 R/PlotSection.R create mode 100644 R/PlotStereoMap.R create mode 100644 R/PlotVsLTime.R create mode 100644 R/ToyModel.R create mode 100644 R/clim.palette.R create mode 100644 man/AnimateMap.Rd create mode 100644 man/CDORemap.Rd create mode 100644 man/ColorBar.Rd create mode 100644 man/LeapYear.Rd create mode 100644 man/Load.Rd create mode 100644 man/Plot2VarsVsLTime.Rd create mode 100644 man/PlotACC.Rd create mode 100644 man/PlotAno.Rd create mode 100644 man/PlotBoxWhisker.Rd create mode 100644 man/PlotClim.Rd create mode 100644 man/PlotEquiMap.Rd create mode 100644 man/PlotLayout.Rd create mode 100644 man/PlotMatrix.Rd create mode 100644 man/PlotSection.Rd create mode 100644 man/PlotStereoMap.Rd create mode 100644 man/PlotVsLTime.Rd create mode 100644 man/ToyModel.Rd create mode 100644 man/clim.palette.Rd diff --git a/R/AnimateMap.R b/R/AnimateMap.R new file mode 100644 index 0000000..83667d2 --- /dev/null +++ b/R/AnimateMap.R @@ -0,0 +1,296 @@ +#'Animate Maps of Forecast/Observed Values or Scores Over Forecast Time +#' +#'Create animations of maps in an equi-rectangular or stereographic +#'projection, showing the anomalies, the climatologies, the mean InterQuartile +#'Range, Maximum-Mininum, Standard Deviation, Median Absolute Deviation, +#'the trends, the RMSE, the correlation or the RMSSS, between modelled and +#'observed data along the forecast time (lead-time) for all input experiments +#'and input observational datasets. +#' +#'@param var Matrix of dimensions (nltime, nlat, nlon) or +#' (nexp/nmod, nltime, nlat, nlon) or (nexp/nmod, 3/4, nltime, nlat, nlon) or +#' (nexp/nmod, nobs, 3/4, nltime, nlat, nlon). +#'@param lon Vector containing longtitudes (degrees). +#'@param lat Vector containing latitudes (degrees). +#'@param toptitle c('','', \dots) array of main title for each animation, +#' optional. If RMS, RMSSS, correlations: first exp with successive obs, then +#' second exp with successive obs, etc ... +#'@param sizetit Multiplicative factor to increase title size, optional. +#'@param units Units, optional. +#'@param monini Starting month between 1 and 12. Default = 1. +#'@param freq 1 = yearly, 12 = monthly, 4 = seasonal ... +#'@param msk95lev TRUE/FALSE grid points with dots if 95\% significance level +#' reached. Default = FALSE. +#'@param brks Limits of colour levels, optional. For example: +#' seq(min(var), max(var), (max(var) - min(var)) / 10). +#'@param cols Vector of colours of length(brks) - 1, optional. +#'@param filled.continents Continents filled in grey (TRUE) or represented by +#' a black line (FALSE). Default = TRUE. Filling unavailable if crossing +#' Greenwich and equi = TRUE. Filling unavailable if square = FALSE and +#' equi = TRUE. +#'@param lonmin Westward limit of the domain to plot (> 0 or < 0). +#' Default : 0 degrees. +#'@param lonmax Eastward limit of the domain to plot (> 0 or < 0). +#' lonmax > lonmin. Default : 360 degrees. +#'@param latmin Southward limit of the domain to plot. Default : -90 degrees. +#'@param latmax Northward limit of the domain to plot. Default : 90 degrees. +#'@param intlat Interval between latitude ticks on y-axis for equi = TRUE or +#' between latitude circles for equi = FALSE. Default = 30 degrees. +#'@param intlon Interval between longitude ticks on x-axis. +#' Default = 20 degrees. +#'@param drawleg Draw a colorbar. Can be FALSE only if square = FALSE or +#' equi = FALSE. Default = TRUE. +#'@param subsampleg Supsampling factor of the interval between ticks on +#' colorbar. Default = 1 = every colour level. +#'@param colNA Color used to represent NA. Default = 'white'. +#'@param equi TRUE/FALSE == cylindrical equidistant/stereographic projection. +#' Default: TRUE. +#'@param fileout c('', '', \dots) array of output file name for each animation. +#' If RMS, RMSSS, correlations : first exp with successive obs, then second +#' exp with successive obs, etc ... +#'@param ... Arguments to be passed to the method. Only accepts the following +#' graphical parameters:\cr +#' adj ann ask bty cex cex.axis cex.lab cex.main cex.sub +#' cin col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig +#' font font.axis font.lab font.main font.sub las lheight ljoin lmitre lty +#' lwd mai mar mex mfcol mfrow mfg mgp mkh oma omd omi page pch plt pty smo +#' srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog. \cr +#' For more information about the parameters see `par`. +#' +#'@details +#'Examples of input: +#'\enumerate{ +#' \item{ +#' Outputs from clim (exp, obs, memb = FALSE): +#' (nmod, nltime, nlat, nlon) +#' or (nobs, nltime, nlat, nlon) +#' } +#' \item{ +#' Model output from load/ano/smoothing: +#' (nmod, nmemb, sdate, nltime, nlat, nlon) +#' then passed through spread(var, posdim = 2, narm = TRUE) +#' & mean1dim(var, posdim = 3, narm = TRUE) +#' or through trend(mean1dim(var, 2), posTR = 2): +#' (nmod, 3, nltime, nlat, nlon) +#' animates average along start dates of IQR/MaxMin/SD/MAD across members +#' or trends of the ensemble-mean computed accross the start dates. +#' } +#' \item{ +#' model and observed output from load/ano/smoothing: +#' (nmod, nmemb, sdate, nltime, nlat, nlon) +#' & (nobs, nmemb, sdate, nltime, nlat, nlon) +#' then averaged along members mean1dim(var_exp/var_obs, posdim = 2): +#' (nmod, sdate, nltime, nlat, nlon) +#' (nobs, sdate, nltime, nlat, nlon) +#' then passed through corr(exp, obs, posloop = 1, poscor = 2) +#' or RMS(exp, obs, posloop = 1, posRMS = 2): +#' (nmod, nobs, 3, nltime, nlat, nlon) +#' animates correlations or RMS between each exp & each obs against leadtime. +#' } +#'} +#' +#'@keywords dynamic +#'@author History:\cr +#' 1.0 - 2012-04 (V. Guemas, \email{virginie.guemas@@bsc.es}) - Original code\cr +#' 1.1 - 2014-04 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Formatting to CRAN\cr +#' 1.2 - 2015-05 (V. Guemas, \email{virginie.guemas@@bsc.es}) - Use of PlotEquiMap and PlotStereoMap +#' +#'@examples +#'# See ?Load for explanations on the first part of this example +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' output = 'lonlat', latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#'clim <- Clim(sampleData$mod, sampleData$obs, memb = FALSE) +#' \dontrun{ +#'AnimateMap(clim$clim_exp, sampleData$lon, sampleData$lat, +#' toptitle = "climatology of decadal prediction", sizetit = 1, +#' units = "degree", brks = seq(270, 300, 3), monini = 11, freq = 12, +#' msk95lev = FALSE, filled.continents = TRUE, intlon = 10, intlat = 10, +#' fileout = 'clim_dec.gif') +#' } +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'leadtimes_dimension <- 4 +#'initial_month <- 11 +#'mean_start_month <- 1 +#'mean_stop_month <- 12 +#'season_means_mod <- Season(ano_exp, leadtimes_dimension, initial_month, +#' mean_start_month, mean_stop_month) +#'season_means_obs <- Season(ano_obs, leadtimes_dimension, initial_month, +#' mean_start_month, mean_stop_month) +#' \dontrun{ +#'AnimateMap(Mean1Dim(season_means_mod, 2)[1, 1, , , ], sampleData$lon, +#' sampleData$lat, toptitle = "Annual anomalies 1985 of decadal prediction", +#' sizetit = 1, units = "degree", monini = 1, freq = 1, msk95lev = FALSE, +#' brks = seq(-0.5, 0.5, 0.1), intlon = 10, intlat = 10, +#' filled.continents = TRUE, fileout = 'annual_means_dec.gif') +#' } +#'dim_to_mean <- 2 # Mean along members +#'rms <- RMS(Mean1Dim(season_means_mod, dim_to_mean), +#' Mean1Dim(season_means_obs, dim_to_mean)) +#' \donttest{ +#'AnimateMap(rms, sampleData$lon, sampleData$lat, toptitle = +#' "RMSE decadal prediction", sizetit = 1, units = "degree", +#' monini = 1, freq = 1, msk95lev = FALSE, brks = seq(0, 0.8, 0.08), +#' intlon = 10, intlat = 10, filled.continents = TRUE, +#' fileout = 'rmse_dec.gif') +#' } +#'@importFrom grDevices postscript dev.off +#'@export +AnimateMap <- function(var, lon, lat, toptitle = rep("", 11), sizetit = 1, + units = "", monini = 1, freq = 12, msk95lev = FALSE, + brks = NULL, cols = NULL, filled.continents = FALSE, + lonmin = 0, lonmax = 360, latmin = -90, latmax = 90, + intlon = 20, intlat = 30, drawleg = TRUE, + subsampleg = 1, colNA = "white", equi = TRUE, + fileout = c("output1_animvsltime.gif", + "output2_animvsltime.gif", + "output3_animvsltime.gif"), ...) { + # Process the user graphical parameters that may be passed in the call + ## Graphical parameters to exclude + excludedArgs <- c("bg", "col", "fin", "lab", "lend", "new", "pin", "ps") + userArgs <- .FilterUserGraphicArgs(excludedArgs, ...) + + ## fileout content with extension for consistency between + ## functions keeping only filename without extension + ext <- regmatches(fileout, regexpr("\\.[a-zA-Z0-9]*$", fileout)) + if ((length(ext) != 0) && any(ext != ".gif")) { + .warning("some or all extensions of the filenames provided in 'fileout' are not 'gif'. The extensions are being converted to 'gif'.") + } + fileout <- sub("\\.[a-zA-Z0-9]*$", "", fileout) + + # + + # Check var + if (!is.numeric(var) || !is.array(var)) { + stop("Parameter 'var' must be a numeric array.") + } + if (length(dim(var)) < 3 || length(dim(var)) > 6) { + stop("Parameter 'var' must be an array with 3 to 6 dimensions.") + } + if (length(dim(var)) == 3) { + var <- InsertDim(var, posdim = 1, lendim = 1) + } + if (length(dim(var)) == 4) { + var <- InsertDim(var, posdim = 2, lendim = 3) + } + if (length(dim(var)) == 5) { + var <- InsertDim(var, posdim = 2, lendim = 1) + } + + nleadtime <- dim(var)[4] + nexp <- dim(var)[1] + nobs <- dim(var)[2] + nlat <- dim(var)[5] + nlon <- dim(var)[6] + if (length(lon) != nlon | length(lat) != nlat) { + stop("Inconsistent var dimensions / longitudes + latitudes") + } + colorbar <- clim.palette() + if (is.null(brks) == TRUE) { + ll <- signif(min(var[, , 2, , , ], na.rm = TRUE), 4) + ul <- signif(max(var[, , 2, , , ], na.rm = TRUE), 4) + if (is.null(cols) == TRUE) { + cols <- colorbar(10) + } + nlev <- length(cols) + brks <- signif(seq(ll, ul, (ul - ll)/nlev), 4) + } else { + if (is.null(cols) == TRUE) { + nlev <- length(brks) - 1 + cols <- colorbar(nlev) + } else { + nlev <- length(cols) + } + } + lon[which(lon < lonmin)] <- lon[which(lon < lonmin)] + 360 + lon[which(lon > lonmax)] <- lon[which(lon > lonmax)] - 360 + latb <- sort(lat[which(lat >= latmin & lat <= latmax)], index.return = TRUE) + lonb <- sort(lon[which(lon >= lonmin & lon <= lonmax)], index.return = TRUE) + + # Define some plot parameters ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + labind <- 1:nleadtime + months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + "Aug", "Sep", "Oct", "Nov", "Dec") + years <- ((labind - 1) * 12/freq + monini - 1)%/%12 + suffixtit <- months[((labind - 1) * 12/freq + monini - 1)%%12 + + 1] + for (jx in 1:nleadtime) { + y2o3dig <- paste("0", as.character(years[jx]), sep = "") + suffixtit[jx] <- paste(suffixtit[jx], "-", substr(y2o3dig, + nchar(y2o3dig) - 1, nchar(y2o3dig)), sep = "") + } + + # Loop on experimental & observational data + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + for (jexp in 1:nexp) { + for (jobs in 1:nobs) { + postscript(paste(fileout[(jexp - 1) * nobs + jobs], + ".png", sep = ""), width = 550, height = 300, + bg = "white") + # Load the user parameters + par(userArgs) + for (jt in 1:nleadtime) { + title <- paste(toptitle[(jexp - 1) * nobs + jobs], + " Time=", suffixtit[jt], sep = "") + varbis <- var[jexp, jobs, 2, jt, which(lat >= + latmin & lat <= latmax), which(lon >= lonmin & + lon <= lonmax)] + varbis <- varbis[latb$ix, lonb$ix] + flag <- array(FALSE, dim(varbis)) + if (msk95lev) { + flag[which(var[jexp, jobs, 1, jt, latb$ix, + lonb$ix] > 0 & var[jexp, jobs, 3, jt, latb$ix, + lonb$ix] > 0)] <- TRUE + flag[which(var[jexp, jobs, 1, jt, latb$ix, + lonb$ix] < 0 & var[jexp, jobs, 3, jt, latb$ix, + lonb$ix] < 0)] <- TRUE + } + varbis[which(varbis <= min(brks))] <- min(brks) + + (max(brks) - min(brks))/1000 + varbis[which(varbis >= max(brks))] <- max(brks) - + (max(brks) - min(brks))/1000 + if (equi) { + PlotEquiMap(t(varbis), lonb$x, latb$x, toptitle = title, + sizetit = sizetit, units = units, filled.continents = filled.continents, + dots = t(flag), brks = brks, cols = cols, + intxlon = intlon, intylat = intlat, drawleg = drawleg, + subsampleg = subsampleg, colNA = colNA, ...) + } else { + PlotStereoMap(t(varbis), lonb$x, latb$x, latlims = c(latmin, + latmax), toptitle = title, sizetit = sizetit, + units = units, filled.continents = filled.continents, + dots = t(flag), brks = brks, cols = cols, + intlat = intlat, drawleg = drawleg, subsampleg = subsampleg, + colNA = colNA, ...) + } + } + dev.off() + system(paste("convert -rotate 90 -loop 10 -delay 50 ", + fileout[(jexp - 1) * nobs + jobs], ".png ", fileout[(jexp - + 1) * nobs + jobs], ".gif", sep = "")) + file.remove(paste0(fileout[(jexp - 1) * nobs + jobs], + ".png")) + } + } +} diff --git a/R/CDORemap.R b/R/CDORemap.R new file mode 100644 index 0000000..ea6ff13 --- /dev/null +++ b/R/CDORemap.R @@ -0,0 +1,1033 @@ +#'Interpolates arrays with longitude and latitude dimensions using CDO +#' +#'This function takes as inputs a multidimensional array (optional), a vector +#'or matrix of longitudes, a vector or matrix of latitudes, a destination grid +#'specification, and the name of a method to be used to interpolate (one of +#'those available in the 'remap' utility in CDO). The interpolated array is +#'returned (if provided) together with the new longitudes and latitudes.\cr\cr +#'\code{CDORemap()} permutes by default the dimensions of the input array (if +#'needed), splits it in chunks (CDO can work with data arrays of up to 4 +#'dimensions), generates a file with the data of each chunk, interpolates it +#'with CDO, reads it back into R and merges it into a result array. If no +#'input array is provided, the longitude and latitude vectors will be +#'transformed only. If the array is already on the desired destination grid, +#'no transformation is performed (this behvaiour works only for lonlat and +#'gaussian grids). \cr\cr +#'Any metadata attached to the input data array, longitudes or latitudes will +#'be preserved or accordingly modified. +#' +#'@param data_array Multidimensional numeric array to be interpolated. If +#' provided, it must have at least a longitude and a latitude dimensions, +#' identified by the array dimension names. The names for these dimensions +#' must be one of the recognized by s2dverification (can be checked with +#' \code{s2dverification:::.KnownLonNames()} and +#' \code{s2dverification:::.KnownLatNames()}). +#'@param lons Numeric vector or array of longitudes of the centers of the grid +#' cells. Its size must match the size of the longitude/latitude dimensions +#' of the input array. +#'@param lats Numeric vector or array of latitudes of the centers of the grid +#' cells. Its size must match the size of the longitude/latitude dimensions +#' of the input array. +#'@param grid Character string specifying either a name of a target grid +#' (recognized by CDO; e.g.: 'r256x128', 't106grid') or a path to another +#' NetCDF file which to read the target grid from (a single grid must be +#' defined in such file). +#'@param method Character string specifying an interpolation method +#' (recognized by CDO; e.g.: 'con', 'bil', 'bic', 'dis'). The following +#' long names are also supported: 'conservative', 'bilinear', 'bicubic' and +#' 'distance-weighted'. +#'@param avoid_writes The step of permutation is needed when the input array +#' has more than 3 dimensions and none of the longitude or latitude dimensions +#' in the right-most position (CDO would not accept it without permuting +#' previously). This step, executed by default when needed, can be avoided +#' for the price of writing more intermediate files (whis usually is +#' unconvenient) by setting the parameter \code{avoid_writes = TRUE}. +#'@param crop Whether to crop the data after interpolation with +#' 'cdo sellonlatbox' (TRUE) or to extend interpolated data to the whole +#' world as CDO does by default (FALSE). If \code{crop = TRUE} then the +#' longitude and latitude borders which to crop at are taken as the limits of +#' the cells at the borders ('lons' and 'lats' are perceived as cell centers), +#' i.e. the resulting array will contain data that covers the same area as +#' the input array. This is equivalent to specifying \code{crop = 'preserve'}, +#' i.e. preserving area. If \code{crop = 'tight'} then the borders which to +#' crop at are taken as the minimum and maximum cell centers in 'lons' and +#' 'lats', i.e. the area covered by the resulting array may be smaller if +#' interpolating from a coarse grid to a fine grid. The parameter 'crop' also +#' accepts a numeric vector of custom borders which to crop at: +#' c(western border, eastern border, southern border, northern border). +#'@param force_remap Whether to force remapping, even if the input data array +#' is already on the target grid. +#'@param write_dir Path to the directory where to create the intermediate +#' files for CDO to work. By default, the R session temporary directory is +#' used (\code{tempdir()}). +#' +#'@return A list with the following components: +#' \item{'data_array'}{The interpolated data array (if an input array +#' is provided at all, NULL otherwise).} +#' \item{'lons'}{The longitudes of the data on the destination grid.} +#' \item{'lats'}{The latitudes of the data on the destination grid.} +#'@keywords datagen +#'@author History:\cr +#' 0.0 - 2017-01 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Original code. +#'@examples +#' \dontrun{ +#'# Interpolating only vectors of longitudes and latitudes +#'lon <- seq(0, 360 - 360/50, length.out = 50) +#'lat <- seq(-90, 90, length.out = 25) +#'tas2 <- CDORemap(NULL, lon, lat, 't170grid', 'bil', TRUE) +#' +#'# Minimal array interpolation +#'tas <- array(1:50, dim = c(25, 50)) +#'names(dim(tas)) <- c('lat', 'lon') +#'lon <- seq(0, 360 - 360/50, length.out = 50) +#'lat <- seq(-90, 90, length.out = 25) +#'tas2 <- CDORemap(tas, lon, lat, 't170grid', 'bil', TRUE) +#' +#'# Metadata can be attached to the inputs. It will be preserved and +#'# accordignly modified. +#'tas <- array(1:50, dim = c(25, 50)) +#'names(dim(tas)) <- c('lat', 'lon') +#'lon <- seq(0, 360 - 360/50, length.out = 50) +#'metadata <- list(lon = list(units = 'degrees_east')) +#'attr(lon, 'variables') <- metadata +#'lat <- seq(-90, 90, length.out = 25) +#'metadata <- list(lat = list(units = 'degrees_north')) +#'attr(lat, 'variables') <- metadata +#'metadata <- list(tas = list(dim = list(lat = list(len = 25, +#' vals = lat), +#' lon = list(len = 50, +#' vals = lon) +#' ))) +#'attr(tas, 'variables') <- metadata +#'tas2 <- CDORemap(tas, lon, lat, 't170grid', 'bil', TRUE) +#' +#'# Arrays of any number of dimensions in any order can be provided. +#'num_lats <- 25 +#'num_lons <- 50 +#'tas <- array(1:(10*num_lats*10*num_lons*10), +#' dim = c(10, num_lats, 10, num_lons, 10)) +#'names(dim(tas)) <- c('a', 'lat', 'b', 'lon', 'c') +#'lon <- seq(0, 360 - 360/num_lons, length.out = num_lons) +#'metadata <- list(lon = list(units = 'degrees_east')) +#'attr(lon, 'variables') <- metadata +#'lat <- seq(-90, 90, length.out = num_lats) +#'metadata <- list(lat = list(units = 'degrees_north')) +#'attr(lat, 'variables') <- metadata +#'metadata <- list(tas = list(dim = list(a = list(), +#' lat = list(len = num_lats, +#' vals = lat), +#' b = list(), +#' lon = list(len = num_lons, +#' vals = lon), +#' c = list() +#' ))) +#'attr(tas, 'variables') <- metadata +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', TRUE) +#'# The step of permutation can be avoided but more intermediate file writes +#'# will be performed. +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', FALSE) +#' +#'# If the provided array has the longitude or latitude dimension in the +#'# right-most position, the same number of file writes will be performed, +#'# even if avoid_wrties = FALSE. +#'num_lats <- 25 +#'num_lons <- 50 +#'tas <- array(1:(10*num_lats*10*num_lons*10), +#' dim = c(10, num_lats, 10, num_lons)) +#'names(dim(tas)) <- c('a', 'lat', 'b', 'lon') +#'lon <- seq(0, 360 - 360/num_lons, length.out = num_lons) +#'metadata <- list(lon = list(units = 'degrees_east')) +#'attr(lon, 'variables') <- metadata +#'lat <- seq(-90, 90, length.out = num_lats) +#'metadata <- list(lat = list(units = 'degrees_north')) +#'attr(lat, 'variables') <- metadata +#'metadata <- list(tas = list(dim = list(a = list(), +#' lat = list(len = num_lats, +#' vals = lat), +#' b = list(), +#' lon = list(len = num_lons, +#' vals = lon) +#' ))) +#'attr(tas, 'variables') <- metadata +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', TRUE) +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', FALSE) +#' +#'# An example of an interpolation from and onto a rectangular regular grid +#'num_lats <- 25 +#'num_lons <- 50 +#'tas <- array(1:(1*num_lats*num_lons), dim = c(num_lats, num_lons)) +#'names(dim(tas)) <- c('y', 'x') +#'lon <- array(seq(0, 360 - 360/num_lons, length.out = num_lons), +#' dim = c(num_lons, num_lats)) +#'metadata <- list(lon = list(units = 'degrees_east')) +#'names(dim(lon)) <- c('x', 'y') +#'attr(lon, 'variables') <- metadata +#'lat <- t(array(seq(-90, 90, length.out = num_lats), +#' dim = c(num_lats, num_lons))) +#'metadata <- list(lat = list(units = 'degrees_north')) +#'names(dim(lat)) <- c('x', 'y') +#'attr(lat, 'variables') <- metadata +#'tas2 <- CDORemap(tas, lon, lat, 'r100x50', 'bil') +#' +#'# An example of an interpolation from an irregular grid onto a gaussian grid +#'num_lats <- 25 +#'num_lons <- 50 +#'tas <- array(1:(10*num_lats*10*num_lons*10), +#' dim = c(10, num_lats, 10, num_lons)) +#'names(dim(tas)) <- c('a', 'j', 'b', 'i') +#'lon <- array(seq(0, 360 - 360/num_lons, length.out = num_lons), +#' dim = c(num_lons, num_lats)) +#'metadata <- list(lon = list(units = 'degrees_east')) +#'names(dim(lon)) <- c('i', 'j') +#'attr(lon, 'variables') <- metadata +#'lat <- t(array(seq(-90, 90, length.out = num_lats), +#' dim = c(num_lats, num_lons))) +#'metadata <- list(lat = list(units = 'degrees_north')) +#'names(dim(lat)) <- c('i', 'j') +#'attr(lat, 'variables') <- metadata +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil') +#' +#'# Again, the dimensions can be in any order +#'num_lats <- 25 +#'num_lons <- 50 +#'tas <- array(1:(10*num_lats*10*num_lons), +#' dim = c(10, num_lats, 10, num_lons)) +#'names(dim(tas)) <- c('a', 'j', 'b', 'i') +#'lon <- array(seq(0, 360 - 360/num_lons, length.out = num_lons), +#' dim = c(num_lons, num_lats)) +#'names(dim(lon)) <- c('i', 'j') +#'lat <- t(array(seq(-90, 90, length.out = num_lats), +#' dim = c(num_lats, num_lons))) +#'names(dim(lat)) <- c('i', 'j') +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil') +#'tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', FALSE) +#'# It is ossible to specify an external NetCDF file as target grid reference +#'tas2 <- CDORemap(tas, lon, lat, 'external_file.nc', 'bil') +#'} +#'@import ncdf4 +#'@importFrom stats lm predict setNames +#'@export +CDORemap <- function(data_array = NULL, lons, lats, grid, method, + avoid_writes = TRUE, crop = TRUE, + force_remap = FALSE, write_dir = tempdir()) { #, mask = NULL) { + .isRegularVector <- function(x, tol = 0.1) { + if (length(x) < 2) { + #stop("The provided vector must be of length 2 or greater.") + TRUE + } else { + spaces <- x[2:length(x)] - x[1:(length(x) - 1)] + (sum(abs(spaces - mean(spaces)) > mean(spaces) / (1 / tol)) < 2) + } + } + # Check parameters data_array, lons and lats. + known_lon_names <- .KnownLonNames() + known_lat_names <- .KnownLatNames() + if (!is.numeric(lons) || !is.numeric(lats)) { + stop("Expected numeric 'lons' and 'lats'.") + } + if (any(is.na(lons > 0))) { + stop("Found invalid values in 'lons'.") + } + if (any(is.na(lats > 0))) { + stop("Found invalid values in 'lats'.") + } + if (is.null(dim(lons))) { + dim(lons) <- length(lons) + } + if (is.null(dim(lats))) { + dim(lats) <- length(lats) + } + if (length(dim(lons)) > 2 || length(dim(lats)) > 2) { + stop("'lons' and 'lats' can only have up to 2 dimensions.") + } + if (length(dim(lons)) != length(dim(lats))) { + stop("'lons' and 'lats' must have the same number of dimensions.") + } + if (length(dim(lons)) == 2 && !all(dim(lons) == dim(lats))) { + stop("'lons' and 'lats' must have the same dimension sizes.") + } + return_array <- TRUE + if (is.null(data_array)) { + return_array <- FALSE + if (length(dim(lons)) == 1) { + array_dims <- c(length(lats), length(lons)) + new_lon_dim_name <- 'lon' + new_lat_dim_name <- 'lat' + } else { + array_dims <- dim(lons) + new_lon_dim_name <- 'i' + new_lat_dim_name <- 'j' + } + if (!is.null(names(dim(lons)))) { + if (any(known_lon_names %in% names(dim(lons)))) { + new_lon_dim_name <- known_lon_names[which(known_lon_names %in% names(dim(lons)))[1]] + } + } + if (!is.null(names(dim(lats)))) { + if (any(known_lat_names %in% names(dim(lats)))) { + new_lat_dim_name <- known_lat_names[which(known_lat_names %in% names(dim(lats)))[1]] + } + } + names(array_dims) <- c(new_lat_dim_name, new_lon_dim_name) + data_array <- array(as.numeric(NA), array_dims) + } + if (!(is.logical(data_array) || is.numeric(data_array)) || !is.array(data_array)) { + stop("Parameter 'data_array' must be a numeric array.") + } + if (is.null(names(dim(data_array)))) { + stop("Parameter 'data_array' must have named dimensions.") + } + lon_dim <- which(known_lon_names %in% names(dim(data_array))) + if (length(lon_dim) < 1) { + stop("Could not find a known longitude dimension name in the provided 'data_array'.") + } + if (length(lon_dim) > 1) { + stop("Found more than one known longitude dimension names in the provided 'data_array'.") + } + lon_dim <- known_lon_names[lon_dim] + lat_dim <- which(known_lat_names %in% names(dim(data_array))) + if (length(lat_dim) < 1) { + stop("Could not find a known latitude dimension name in the provided 'data_array'.") + } + if (length(lat_dim) > 1) { + stop("Found more than one known latitude dimension name in the provided 'data_array'.") + } + lat_dim <- known_lat_names[lat_dim] + if (is.null(names(dim(lons)))) { + if (length(dim(lons)) == 1) { + names(dim(lons)) <- lon_dim + } else { + stop("Parameter 'lons' must be provided with dimension names.") + } + } else { + if (!(lon_dim %in% names(dim(lons)))) { + stop("Parameter 'lon' must have the same longitude dimension name as the 'data_array'.") + } + if (length(dim(lons)) > 1 && !(lat_dim %in% names(dim(lons)))) { + stop("Parameter 'lon' must have the same latitude dimension name as the 'data_array'.") + } + } + if (is.null(names(dim(lats)))) { + if (length(dim(lats)) == 1) { + names(dim(lats)) <- lat_dim + } else { + stop("Parameter 'lats' must be provided with dimension names.") + } + } else { + if (!(lat_dim %in% names(dim(lats)))) { + stop("Parameter 'lat' must have the same latitude dimension name as the 'data_array'.") + } + if (length(dim(lats)) > 1 && !(lon_dim %in% names(dim(lats)))) { + stop("Parameter 'lat' must have the same longitude dimension name as the 'data_array'.") + } + } + lons_attr_bk <- attributes(lons) + if (is.null(lons_attr_bk)) { + lons_attr_bk <- list() + } + lats_attr_bk <- attributes(lats) + if (is.null(lats_attr_bk)) { + lats_attr_bk <- list() + } + if (length(attr(lons, 'variables')) == 0) { + new_metadata <- list(list()) + if (length(dim(lons)) == 1) { + names(new_metadata) <- lon_dim + } else { + names(new_metadata) <- paste0(lon_dim, '_var') + } + attr(lons, 'variables') <- new_metadata + } + if (!('units' %in% names(attr(lons, 'variables')[[1]]))) { + new_metadata <- attr(lons, 'variables') + #names(new_metadata)[1] <- lon_dim + new_metadata[[1]][['units']] <- 'degrees_east' + attr(lons, 'variables') <- new_metadata + } + if (length(attr(lats, 'variables')) == 0) { + new_metadata <- list(list()) + if (length(dim(lats)) == 1) { + names(new_metadata) <- lat_dim + } else { + names(new_metadata) <- paste0(lat_dim, '_var') + } + attr(lats, 'variables') <- new_metadata + } + if (!('units' %in% names(attr(lats, 'variables')[[1]]))) { + new_metadata <- attr(lats, 'variables') + #names(new_metadata)[1] <- lat_dim + new_metadata[[1]][['units']] <- 'degrees_north' + attr(lats, 'variables') <- new_metadata + } + # Check grid. + if (!is.character(grid)) { + stop("Parameter 'grid' must be a character string specifying a ", + "target CDO grid, 'rXxY' or 'tRESgrid', or a path to another ", + "NetCDF file.") + } + if (grepl('^r[0-9]{1,}x[0-9]{1,}$', grid)) { + grid_type <- 'regular' + grid_lons <- as.numeric(strsplit(strsplit(grid, 'x')[[1]][1], 'r')[[1]][2]) + grid_lats <- as.numeric(strsplit(grid, 'x')[[1]][2]) + } else if (grepl('^t[0-9]{1,}grid$', grid)) { + grid_type <- 'gaussian' + grid_t <- as.numeric(strsplit(strsplit(grid, 'grid')[[1]][1], 't')[[1]][2]) + grid_size <- .t2nlatlon(grid_t) + grid_lons <- grid_size[2] + grid_lats <- grid_size[1] + } else { + grid_type <- 'custom' + } + # Check method. + if (method %in% c('bil', 'bilinear')) { + method <- 'bil' + } else if (method %in% c('bic', 'bicubic')) { + method <- 'bic' + } else if (method %in% c('con', 'conservative')) { + method <- 'con' + } else if (method %in% c('dis', 'distance-weighted')) { + method <- 'dis' + } else { + stop("Unsupported CDO remap method. 'bilinear', 'bicubic', 'conservative' or 'distance-weighted' supported only.") + } + # Check avoid_writes + if (!is.logical(avoid_writes)) { + stop("Parameter 'avoid_writes' must be a logical value.") + } + # Check crop + crop_tight <- FALSE + if (is.character(crop)) { + if (crop == 'tight') { + crop_tight <- TRUE + } else if (crop != 'preserve') { + stop("Parameter 'crop' can only take the values 'tight' or 'preserve' if specified as a character string.") + } + crop <- TRUE + } + if (is.logical(crop)) { + if (crop) { + warning("Parameter 'crop' = 'TRUE'. The output grid range will follow the input lons and lats.") + if (length(lons) == 1 || length(lats) == 1) { + stop("CDORemap cannot remap if crop = TRUE and values for only one ", + "longitude or one latitude are provided. Either a) provide ", + "values for more than one longitude/latitude, b) explicitly ", + "specify the crop limits in the parameter crop, or c) set ", + "crop = FALSE.") + } + if (crop_tight) { + lon_extremes <- c(min(lons), max(lons)) + lat_extremes <- c(min(lats), max(lats)) + } else { + # Here we are trying to look for the extreme lons and lats in the data. + # Not the centers of the extreme cells, but the borders of the extreme cells. +###--- + if (length(dim(lons)) == 1) { + tmp_lon <- lons + } else { + min_pos <- which(lons == min(lons), arr.ind = TRUE)[1, ] + tmp_lon <- Subset(lons, lat_dim, min_pos[which(names(dim(lons)) == lat_dim)], drop = 'selected') + } + i <- 1:length(tmp_lon) + degree <- min(3, length(i) - 1) + lon_model <- lm(tmp_lon ~ poly(i, degree)) + lon_extremes <- c(NA, NA) + left_is_min <- FALSE + right_is_max <- FALSE + if (which.min(tmp_lon) == 1) { + left_is_min <- TRUE + prev_lon <- predict(lon_model, data.frame(i = 0)) + first_lon_cell_width <- (tmp_lon[1] - prev_lon) + # The signif is needed because cdo sellonlatbox crashes with too many digits + lon_extremes[1] <- tmp_lon[1] - first_lon_cell_width / 2 + } else { + lon_extremes[1] <- min(tmp_lon) + } + if (which.max(tmp_lon) == length(tmp_lon)) { + right_is_max <- TRUE + next_lon <- predict(lon_model, data.frame(i = length(tmp_lon) + 1)) + last_lon_cell_width <- (next_lon - tmp_lon[length(tmp_lon)]) + lon_extremes[2] <- tmp_lon[length(tmp_lon)] + last_lon_cell_width / 2 + } else { + lon_extremes[2] <- max(tmp_lon) + } + # Adjust the crop window if possible in order to keep lons from 0 to 360 + # or from -180 to 180 when the extremes of the cropped window are contiguous. + if (right_is_max) { + if (lon_extremes[1] < -180) { + if (!((lon_extremes[2] < 180) && !((180 - lon_extremes[2]) <= last_lon_cell_width / 2))) { + lon_extremes[1] <- -180 + lon_extremes[2] <- 180 + } + } else if (lon_extremes[1] < 0) { + if (!((lon_extremes[2] < 360) && !((360 - lon_extremes[2]) <= last_lon_cell_width / 2))) { + lon_extremes[1] <- 0 + lon_extremes[2] <- 360 + } + } + } + if (left_is_min) { + if (lon_extremes[2] > 360) { + if (!((lon_extremes[1] > 0) && !(lon_extremes[1] <= first_lon_cell_width / 2))) { + lon_extremes[1] <- 0 + lon_extremes[2] <- 360 + } + } else if (lon_extremes[2] > 180) { + if (!((lon_extremes[1] > -180) && !((180 + lon_extremes[1]) <= first_lon_cell_width / 2))) { + lon_extremes[1] <- -180 + lon_extremes[2] <- 180 + } + } + } +## lon_extremes <- signif(lon_extremes, 5) +## lon_extremes <- lon_extremes + 0.00001 +###--- + if (length(dim(lats)) == 1) { + tmp_lat <- lats + } else { + min_pos <- which(lats == min(lats), arr.ind = TRUE)[1, ] + tmp_lat <- Subset(lats, lon_dim, min_pos[which(names(dim(lats)) == lon_dim)], drop = 'selected') + } + i <- 1:length(tmp_lat) + degree <- min(3, length(i) - 1) + lat_model <- lm(tmp_lat ~ poly(i, degree)) + lat_extremes <- c(NA, NA) + if (which.min(tmp_lat) == 1) { + prev_lat <- predict(lat_model, data.frame(i = 0)) + lat_extremes[1] <- tmp_lat[1] - (tmp_lat[1] - prev_lat) / 2 + } else { + lat_extremes[1] <- min(tmp_lat) + } + if (which.max(tmp_lat) == length(tmp_lat)) { + next_lat <- predict(lat_model, data.frame(i = length(tmp_lat) + 1)) + lat_extremes[2] <- tmp_lat[length(tmp_lat)] + (next_lat - tmp_lat[length(tmp_lat)]) / 2 + } else { + lat_extremes[2] <- max(tmp_lat) + } +## lat_extremes <- signif(lat_extremes, 5) + # Adjust crop window + if (lat_extremes[1] < -90) { + lat_extremes[1] <- -90 + } else if (lat_extremes[1] > 90) { + lat_extremes[1] <- 90 + } + if (lat_extremes[2] < -90) { + lat_extremes[2] <- -90 + } else if (lat_extremes[2] > 90) { + lat_extremes[2] <- 90 + } +###--- + } + } else if (crop == FALSE) { + warning("Parameter 'crop' = 'FALSE'. The output grid range will follow parameter 'grid'.") + } + } else if (is.numeric(crop)) { + if (length(crop) != 4) { + stop("Paramrter 'crop' must be a logical value or a numeric vector of length 4: c(western border, eastern border, southern border, northern border.") + } else { + lon_extremes <- crop[1:2] + lat_extremes <- crop[3:4] + crop <- TRUE + } + } else { + stop("Parameter 'crop' must be a logical value or a numeric vector.") + } + # Check force_remap + if (!is.logical(force_remap)) { + stop("Parameter 'force_remap' must be a logical value.") + } + # Check write_dir + if (!is.character(write_dir)) { + stop("Parameter 'write_dir' must be a character string.") + } + if (!dir.exists(write_dir)) { + stop("Parameter 'write_dir' must point to an existing directory.") + } +# if (!is.null(mask)) { +# if (!is.numeric(mask) || !is.array(mask)) { +# stop("Parameter 'mask' must be a numeric array.") +# } +# if (length(dim(mask)) != 2) { +# stop("Parameter 'mask' must have two dimensions.") +# } +# if (is.null(names(dim(mask)))) { +# if (dim(data_array)[lat_dim] == dim(data_array)[lon_dim]) { +# stop("Cannot disambiguate which is the longitude dimension of ", +# "the provided 'mask'. Provide it with dimension names.") +# } +# names(dim(mask)) <- c('', '') +# found_lon_dim <- which(dim(mask) == dim(data_array)[lon_dim]) +# if (length(found_lon_dim) < 0) { +# stop("The dimension sizes of the provided 'mask' do not match ", +# "the spatial dimension sizes of the array to interpolate.") +# } else { +# names(dim(mask)[found_lon_dim]) <- lon_dim +# } +# found_lat_dim <- which(dim(mask) == dim(data_array)[lat_dim]) +# if (length(found_lat_dim) < 0) { +# stop("The dimension sizes of the provided 'mask' do not match ", +# "the spatial dimension sizes of the array to interpolate.") +# } else { +# names(dim(mask)[found_lat_dim]) <- lat_dim +# } +# } +# lon_position <- which(names(dim(data_array)) == lon_dim) +# lat_position <- which(names(dim(data_array)) == lat_dim) +# if (lon_position > lat_position) { +# if (names(dim(mask))[1] == lon_dim) { +# mask <- t(mask) +# } +# } else { +# if (names(dim(mask))[1] == lat_dim) { +# mask <- t(mask) +# } +# } +# ## TODO: Apply mask!!! Preserve attributes +# } + # Check if interpolation can be skipped. + interpolation_needed <- TRUE + if (!force_remap) { + if (!(grid_type == 'custom')) { + if (length(lons) == grid_lons && length(lats) == grid_lats) { + if (grid_type == 'regular') { + if (.isRegularVector(lons) && .isRegularVector(lats)) { + interpolation_needed <- FALSE + } + } else if (grid_type == 'gaussian') { + # TODO: improve this check. Gaussian quadrature should be used. + if (.isRegularVector(lons) && !.isRegularVector(lats)) { + interpolation_needed <- FALSE + } + } + } + } + } + found_lons <- lons + found_lats <- lats + if (interpolation_needed) { + if (nchar(Sys.which('cdo')[1]) < 1) { + stop("CDO must be installed in order to use the .CDORemap.") + } + cdo_version <- as.numeric_version( + strsplit(suppressWarnings(system2("cdo", args = '-V', stderr = TRUE))[[1]], ' ')[[1]][5] + ) + warning("CDORemap: Using CDO version ", cdo_version, ".") + if ((cdo_version >= as.numeric_version('1.7.0')) && (method == 'con')) { + method <- 'ycon' + } + # CDO takes arrays of 3 dimensions or 4 if one of them is unlimited. + # The unlimited dimension can only be the left-most (right-most in R). + # There are no restrictions for the dimension names or variable names. + # The longitude and latitude are detected by their units. + # There are no restrictions for the order of the limited dimensions. + # The longitude/latitude variables and dimensions must have the same name. + # The procedure consists in: + # - take out the array metadata + # - be aware of var dimension (replacing the dimension names would do). + # - take arrays of 4 dimensions always if possible + # - make the last dimension unlimited when saving to netcdf + # - if the last dimension is lon or lat, either reorder the array and + # then reorder back or iterate over the dimensions at the right + # side of lon AND lat. + # If the input array has more than 4 dimensions, it is needed to + # run CDO on each sub-array of 4 dimensions because it can handle + # only up to 4 dimensions. The shortest dimensions are chosen to + # iterate over. + is_irregular <- FALSE + if (length(dim(lats)) > 1 && length(dim(lons)) > 1) { + is_irregular <- TRUE + } + attribute_backup <- attributes(data_array) + other_dims <- which(!(names(dim(data_array)) %in% c(lon_dim, lat_dim))) + permutation <- NULL + unlimited_dim <- NULL + dims_to_iterate <- NULL + total_slices <- 1 + other_dims_per_chunk <- ifelse(is_irregular, 1, 2) # 4 (the maximum accepted by CDO) - 2 (lon, lat) = 2. + if (length(other_dims) > 1 || (length(other_dims) > 0 && (is_irregular))) { + if (!(length(dim(data_array)) %in% other_dims)) { + if (avoid_writes || is_irregular) { + dims_mod <- dim(data_array) + dims_mod[which(names(dim(data_array)) %in% + c(lon_dim, lat_dim))] <- 0 + dim_to_move <- which.max(dims_mod) + permutation <- (1:length(dim(data_array)))[-dim_to_move] + permutation <- c(permutation, dim_to_move) + permutation_back <- sort(permutation, index.return = TRUE)$ix + dim_backup <- dim(data_array) + data_array <- aperm(data_array, permutation) + dim(data_array) <- dim_backup[permutation] + other_dims <- which(!(names(dim(data_array)) %in% c(lon_dim, lat_dim))) + } else { + # We allow only lon, lat and 1 more dimension per chunk, so + # CDO has no restrictions in the order. + other_dims_per_chunk <- 1 + } + } + other_dims_ordered_by_size <- other_dims[sort(dim(data_array)[other_dims], index.return = TRUE)$ix] + dims_to_iterate <- sort(head(other_dims_ordered_by_size, length(other_dims) - other_dims_per_chunk)) + if (length(dims_to_iterate) == 0) { + dims_to_iterate <- NULL + } else { + slices_to_iterate <- array(1:prod(dim(data_array)[dims_to_iterate]), + dim(data_array)[dims_to_iterate]) + total_slices <- prod(dim(slices_to_iterate)) + } + if ((other_dims_per_chunk > 1) || (other_dims_per_chunk > 0 && is_irregular)) { + unlimited_dim <- tail(sort(tail(other_dims_ordered_by_size, other_dims_per_chunk)), 1) + #unlimited_dim <- tail(other_dims) + } + } + + result_array <- NULL + lon_pos <- which(names(dim(data_array)) == lon_dim) + lat_pos <- which(names(dim(data_array)) == lat_dim) + dim_backup <- dim(data_array) + attributes(data_array) <- NULL + dim(data_array) <- dim_backup + names(dim(data_array)) <- paste0('dim', 1:length(dim(data_array))) + names(dim(data_array))[c(lon_pos, lat_pos)] <- c(lon_dim, lat_dim) + if (!is.null(unlimited_dim)) { + # This will make ArrayToNetCDF create this dim as unlimited. + names(dim(data_array))[unlimited_dim] <- 'time' + } + if (length(dim(lons)) == 1) { + names(dim(lons)) <- lon_dim + } + if (length(dim(lats)) == 1) { + names(dim(lats)) <- lat_dim + } + if (length(dim(lons)) > 1) { + lon_var_name <- paste0(lon_dim, '_var') + } else { + lon_var_name <- lon_dim + } + if (length(dim(lats)) > 1) { + lat_var_name <- paste0(lat_dim, '_var') + } else { + lat_var_name <- lat_dim + } + if (is_irregular) { + metadata <- list(list(coordinates = paste(lon_var_name, lat_var_name))) + names(metadata) <- 'var' + attr(data_array, 'variables') <- metadata + } + names(attr(lons, 'variables')) <- lon_var_name + names(attr(lats, 'variables')) <- lat_var_name + if (!is.null(attr(lons, 'variables')[[1]][['dim']])) { + attr(lons, 'variables')[[1]][['dim']] <- NULL + } + if (!is.null(attr(lats, 'variables')[[1]][['dim']])) { + attr(lats, 'variables')[[1]][['dim']] <- NULL + } + lons_lats_taken <- FALSE + for (i in 1:total_slices) { + tmp_file <- tempfile('R_CDORemap_', write_dir, fileext = '.nc') + tmp_file2 <- tempfile('R_CDORemap_', write_dir, fileext = '.nc') + if (!is.null(dims_to_iterate)) { + slice_indices <- which(slices_to_iterate == i, arr.ind = TRUE) + subset <- Subset(data_array, dims_to_iterate, as.list(slice_indices), drop = 'selected') +# dims_before_crop <- dim(subset) + # Make sure subset goes along with metadata + ArrayToNetCDF(setNames(list(subset, lons, lats), c('var', lon_var_name, lat_var_name)), tmp_file) + } else { +# dims_before_crop <- dim(data_array) + ArrayToNetCDF(setNames(list(data_array, lons, lats), c('var', lon_var_name, lat_var_name)), tmp_file) + } + sellonlatbox <- '' + if (crop) { + sellonlatbox <- paste0('sellonlatbox,', format(lon_extremes[1], scientific = FALSE), + ',', format(lon_extremes[2], scientific = FALSE), + ',', format(lat_extremes[1], scientific = FALSE), + ',', format(lat_extremes[2], scientific = FALSE), ' -') + } + err <- try({ + system(paste0("cdo -s ", sellonlatbox, "remap", method, ",", grid, " ", tmp_file, " ", tmp_file2)) + }) + file.remove(tmp_file) + if (('try-error' %in% class(err)) || err > 0) { + stop("CDO remap failed.") + } + ncdf_remapped <- nc_open(tmp_file2) + if (!lons_lats_taken) { + found_dim_names <- sapply(ncdf_remapped$var$var$dim, '[[', 'name') + found_lon_dim <- found_dim_names[which(found_dim_names %in% .KnownLonNames())[1]] + found_lat_dim <- found_dim_names[which(found_dim_names %in% .KnownLatNames())[1]] + found_lon_dim_size <- length(ncdf_remapped$dim[[found_lon_dim]]$vals) + found_lat_dim_size <- length(ncdf_remapped$dim[[found_lat_dim]]$vals) + found_var_names <- names(ncdf_remapped$var) + found_lon_var_name <- which(found_var_names %in% .KnownLonNames()) + found_lat_var_name <- which(found_var_names %in% .KnownLatNames()) + if (length(found_lon_var_name) > 0) { + found_lon_var_name <- found_var_names[found_lon_var_name[1]] + } else { + found_lon_var_name <- NULL + } + if (length(found_lat_var_name) > 0) { + found_lat_var_name <- found_var_names[found_lat_var_name[1]] + } else { + found_lat_var_name <- NULL + } + if (length(found_lon_var_name) > 0) { + found_lons <- ncvar_get(ncdf_remapped, found_lon_var_name, + collapse_degen = FALSE) + } else { + found_lons <- ncdf_remapped$dim[[found_lon_dim]]$vals + dim(found_lons) <- found_lon_dim_size + } + if (length(found_lat_var_name) > 0) { + found_lats <- ncvar_get(ncdf_remapped, found_lat_var_name, + collapse_degen = FALSE) + } else { + found_lats <- ncdf_remapped$dim[[found_lat_dim]]$vals + dim(found_lats) <- found_lat_dim_size + } + if (length(dim(lons)) == length(dim(found_lons))) { + new_lon_name <- lon_dim + } else { + new_lon_name <- found_lon_dim + } + if (length(dim(lats)) == length(dim(found_lats))) { + new_lat_name <- lat_dim + } else { + new_lat_name <- found_lat_dim + } + if (length(dim(found_lons)) > 1) { + if (which(sapply(ncdf_remapped$var$lon$dim, '[[', 'name') == found_lon_dim) < + which(sapply(ncdf_remapped$var$lon$dim, '[[', 'name') == found_lat_dim)) { + names(dim(found_lons)) <- c(new_lon_name, new_lat_name) + } else { + names(dim(found_lons)) <- c(new_lat_name, new_lon_name) + } + } else { + names(dim(found_lons)) <- new_lon_name + } + if (length(dim(found_lats)) > 1) { + if (which(sapply(ncdf_remapped$var$lat$dim, '[[', 'name') == found_lon_dim) < + which(sapply(ncdf_remapped$var$lat$dim, '[[', 'name') == found_lat_dim)) { + names(dim(found_lats)) <- c(new_lon_name, new_lat_name) + } else { + names(dim(found_lats)) <- c(new_lat_name, new_lon_name) + } + } else { + names(dim(found_lats)) <- new_lat_name + } + lons_lats_taken <- TRUE + } + if (!is.null(dims_to_iterate)) { + if (is.null(result_array)) { + if (return_array) { + new_dims <- dim(data_array) + new_dims[c(lon_dim, lat_dim)] <- c(found_lon_dim_size, found_lat_dim_size) + result_array <- array(dim = new_dims) + store_indices <- as.list(rep(TRUE, length(dim(result_array)))) + } + } + if (return_array) { + store_indices[dims_to_iterate] <- as.list(slice_indices) + result_array <- do.call('[<-', c(list(x = result_array), store_indices, + list(value = ncvar_get(ncdf_remapped, 'var', collapse_degen = FALSE)))) + } + } else { + new_dims <- dim(data_array) + new_dims[c(lon_dim, lat_dim)] <- c(found_lon_dim_size, found_lat_dim_size) + result_array <- ncvar_get(ncdf_remapped, 'var', collapse_degen = FALSE) + dim(result_array) <- new_dims + } + nc_close(ncdf_remapped) + file.remove(tmp_file2) + } + if (!is.null(permutation)) { + dim_backup <- dim(result_array) + result_array <- aperm(result_array, permutation_back) + dim(result_array) <- dim_backup[permutation_back] + } + # Now restore the metadata + result_is_irregular <- FALSE + if (length(dim(found_lats)) > 1 && length(dim(found_lons)) > 1) { + result_is_irregular <- TRUE + } + attribute_backup[['dim']][which(names(dim(result_array)) == lon_dim)] <- dim(result_array)[lon_dim] + attribute_backup[['dim']][which(names(dim(result_array)) == lat_dim)] <- dim(result_array)[lat_dim] + names(attribute_backup[['dim']])[which(names(dim(result_array)) == lon_dim)] <- new_lon_name + names(attribute_backup[['dim']])[which(names(dim(result_array)) == lat_dim)] <- new_lat_name + if (!is.null(attribute_backup[['variables']]) && (length(attribute_backup[['variables']]) > 0)) { + for (var in 1:length(attribute_backup[['variables']])) { + if (length(attribute_backup[['variables']][[var]][['dim']]) > 0) { + for (dim in 1:length(attribute_backup[['variables']][[var]][['dim']])) { + dim_name <- NULL + if ('name' %in% names(attribute_backup[['variables']][[var]][['dim']][[dim]])) { + dim_name <- attribute_backup[['variables']][[var]][['dim']][[dim]][['name']] + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + attribute_backup[['variables']][[var]][['dim']][[dim]][['name']] <- new_lon_name + } else { + attribute_backup[['variables']][[var]][['dim']][[dim]][['name']] <- new_lat_name + } + } + } else if (!is.null(names(attribute_backup[['variables']][[var]][['dim']]))) { + dim_name <- names(attribute_backup[['variables']][[var]][['dim']])[dim] + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + names(attribute_backup[['variables']][[var]][['dim']])[which(names(attribute_backup[['variables']][[var]][['dim']]) == lon_dim)] <- new_lon_name + } else { + names(attribute_backup[['variables']][[var]][['dim']])[which(names(attribute_backup[['variables']][[var]][['dim']]) == lat_dim)] <- new_lat_name + } + } + } + if (!is.null(dim_name)) { + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + new_vals <- found_lons[TRUE] + } else if (dim_name == lat_dim) { + new_vals <- found_lats[TRUE] + } + if (!is.null(attribute_backup[['variables']][[var]][['dim']][[dim]][['len']])) { + attribute_backup[['variables']][[var]][['dim']][[dim]][['len']] <- length(new_vals) + } + if (!is.null(attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']])) { + if (!result_is_irregular) { + attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']] <- new_vals + } else { + attribute_backup[['variables']][[var]][['dim']][[dim]][['vals']] <- 1:length(new_vals) + } + } + } + } + } + } + if (!is_irregular && result_is_irregular) { + attribute_backup[['coordinates']] <- paste(lon_var_name, lat_var_name) + } else if (is_irregular && !result_is_irregular) { + attribute_backup[['coordinates']] <- NULL + } + } + } + attributes(result_array) <- attribute_backup + lons_attr_bk[['dim']] <- dim(found_lons) + if (!is.null(lons_attr_bk[['variables']]) && (length(lons_attr_bk[['variables']]) > 0)) { + for (var in 1:length(lons_attr_bk[['variables']])) { + if (length(lons_attr_bk[['variables']][[var]][['dim']]) > 0) { + dims_to_remove <- NULL + for (dim in 1:length(lons_attr_bk[['variables']][[var]][['dim']])) { + dim_name <- NULL + if ('name' %in% names(lons_attr_bk[['variables']][[var]][['dim']][[dim]])) { + dim_name <- lons_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] <- new_lon_name + } else { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] <- new_lat_name + } + } + } else if (!is.null(names(lons_attr_bk[['variables']][[var]][['dim']]))) { + dim_name <- names(lons_attr_bk[['variables']][[var]][['dim']])[dim] + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + names(lons_attr_bk[['variables']][[var]][['dim']])[which(names(lons_attr_bk[['variables']][[var]][['dim']]) == lon_dim)] <- new_lon_name + } else { + names(lons_attr_bk[['variables']][[var]][['dim']])[which(names(lons_attr_bk[['variables']][[var]][['dim']]) == lat_dim)] <- new_lat_name + } + } + } + if (!is.null(dim_name)) { + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + new_vals <- found_lons[TRUE] + } else if (dim_name == lat_dim) { + new_vals <- found_lats[TRUE] + if (!result_is_irregular) { + dims_to_remove <- c(dims_to_remove, dim) + } + } + if (!is.null(lons_attr_bk[['variables']][[var]][['dim']][[dim]][['len']])) { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['len']] <- length(new_vals) + } + if (!is.null(lons_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']])) { + if (!result_is_irregular) { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- new_vals + } else { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- 1:length(new_vals) + } + } + } + } + } + if (length(dims_to_remove) > 1) { + lons_attr_bk[['variables']][[var]][['dim']] <- lons_attr_bk[['variables']][[var]][['dim']][[-dims_to_remove]] + } + } + } + names(lons_attr_bk[['variables']])[1] <- lon_var_name + lons_attr_bk[['variables']][[1]][['units']] <- 'degrees_east' + } + attributes(found_lons) <- lons_attr_bk + lats_attr_bk[['dim']] <- dim(found_lats) + if (!is.null(lats_attr_bk[['variables']]) && (length(lats_attr_bk[['variables']]) > 0)) { + for (var in 1:length(lats_attr_bk[['variables']])) { + if (length(lats_attr_bk[['variables']][[var]][['dim']]) > 0) { + dims_to_remove <- NULL + for (dim in 1:length(lats_attr_bk[['variables']][[var]][['dim']])) { + dim_name <- NULL + if ('name' %in% names(lats_attr_bk[['variables']][[var]][['dim']][[dim]])) { + dim_name <- lats_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] <- new_lon_name + } else { + lons_attr_bk[['variables']][[var]][['dim']][[dim]][['name']] <- new_lat_name + } + } + } else if (!is.null(names(lats_attr_bk[['variables']][[var]][['dim']]))) { + dim_name <- names(lats_attr_bk[['variables']][[var]][['dim']])[dim] + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + names(lats_attr_bk[['variables']][[var]][['dim']])[which(names(lats_attr_bk[['variables']][[var]][['dim']]) == lon_dim)] <- new_lon_name + } else { + names(lats_attr_bk[['variables']][[var]][['dim']])[which(names(lats_attr_bk[['variables']][[var]][['dim']]) == lat_dim)] <- new_lat_name + } + } + } + if (!is.null(dim_name)) { + if (dim_name %in% c(lon_dim, lat_dim)) { + if (dim_name == lon_dim) { + new_vals <- found_lons[TRUE] + if (!result_is_irregular) { + dims_to_remove <- c(dims_to_remove, dim) + } + } else if (dim_name == lat_dim) { + new_vals <- found_lats[TRUE] + } + if (!is.null(lats_attr_bk[['variables']][[var]][['dim']][[dim]][['len']])) { + lats_attr_bk[['variables']][[var]][['dim']][[dim]][['len']] <- length(new_vals) + } + if (!is.null(lats_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']])) { + if (!result_is_irregular) { + lats_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- new_vals + } else { + lats_attr_bk[['variables']][[var]][['dim']][[dim]][['vals']] <- 1:length(new_vals) + } + } + } + } + } + if (length(dims_to_remove) > 1) { + lats_attr_bk[['variables']][[var]][['dim']] <- lats_attr_bk[['variables']][[var]][['dim']][[-dims_to_remove]] + } + } + } + names(lats_attr_bk[['variables']])[1] <- lat_var_name + lats_attr_bk[['variables']][[1]][['units']] <- 'degrees_north' + } + attributes(found_lats) <- lats_attr_bk + } + list(data_array = if (return_array) { + if (interpolation_needed) { + result_array + } else { + data_array + } + } else { + NULL + }, + lons = found_lons, lats = found_lats) +} diff --git a/R/ColorBar.R b/R/ColorBar.R new file mode 100644 index 0000000..49b82af --- /dev/null +++ b/R/ColorBar.R @@ -0,0 +1,600 @@ +#'Draws a Color Bar +#' +#'Generates a color bar to use as colouring function for map plots and +#'optionally draws it (horizontally or vertically) to be added to map +#'multipanels or plots. It is possible to draw triangles at the ends of the +#'colour bar to represent values that go beyond the range of interest. A +#'number of options is provided to adjust the colours and the position and +#'size of the components. The drawn colour bar spans a whole figure region +#'and is compatible with figure layouts.\cr\cr +#'The generated colour bar consists of a set of breaks that define the +#'length(brks) - 1 intervals to classify each of the values in each of the +#'grid cells of a two-dimensional field. The corresponding grid cell of a +#'given value of the field will be coloured in function of the interval it +#'belongs to.\cr\cr +#'The only mandatory parameters are 'var_limits' or 'brks' (in its second +#'format, see below). +#' +#'@param brks Can be provided in two formats: +#'\itemize{ +#' \item{A single value with the number of breaks to be generated +#' automatically, between the minimum and maximum specified in 'var_limits' +#' (both inclusive). Hence the parameter 'var_limits' is mandatory if 'brks' +#' is provided with this format. If 'bar_limits' is additionally provided, +#' values only between 'bar_limits' will be generated. The higher the value +#' of 'brks', the smoother the plot will look.} +#' \item{A vector with the actual values of the desired breaks. Values will +#' be reordered by force to ascending order. If provided in this format, no +#' other parameters are required to generate/plot the colour bar.} +#'} +#' This parameter is optional if 'var_limits' is specified. If 'brks' not +#' specified but 'cols' is specified, it will take as value length(cols) + 1. +#' If 'cols' is not specified either, 'brks' will take 21 as value. +#'@param cols Vector of length(brks) - 1 valid colour identifiers, for each +#' interval defined by the breaks. This parameter is optional and will be +#' filled in with a vector of length(brks) - 1 colours generated with the +#' function provided in 'color_fun' (\code{clim.colors} by default).\cr 'cols' +#' can have one additional colour at the beginning and/or at the end with the +#' aim to colour field values beyond the range of interest represented in the +#' colour bar. If any of these extra colours is provided, parameter +#' 'triangle_ends' becomes mandatory in order to disambiguate which of the +#' ends the colours have been provided for. +#'@param vertical TRUE/FALSE for vertical/horizontal colour bar +#' (disregarded if plot = FALSE). +#'@param subsampleg The first of each subsampleg breaks will be ticked on the +#' colorbar. Takes by default an approximation of a value that yields a +#' readable tick arrangement (extreme breaks always ticked). If set to 0 or +#' lower, no labels are drawn. See the code of the function for details or +#' use 'extra_labels' for customized tick arrangements. +#'@param bar_limits Vector of two numeric values with the extremes of the +#' range of values represented in the colour bar. If 'var_limits' go beyond +#' this interval, the drawing of triangle extremes is triggered at the +#' corresponding sides, painted in 'col_inf' and 'col_sup'. Either of them +#' can be set as NA and will then take as value the corresponding extreme in +#' 'var_limits' (hence a triangle end won't be triggered for these sides). +#' Takes as default the extremes of 'brks' if available, else the same values +#' as 'var_limits'. +#'@param var_limits Vector of two numeric values with the minimum and maximum +#' values of the field to represent. These are used to know whether to draw +#' triangle ends at the extremes of the colour bar and what colour to fill +#' them in with. If not specified, take the same value as the extremes of +#' 'brks'. Hence the parameter 'brks' is mandatory if 'var_limits' is not +#' specified. +#'@param triangle_ends Vector of two logical elements, indicating whether to +#' force the drawing of triangle ends at each of the extremes of the colour +#' bar. This choice is automatically made from the provided 'brks', +#' 'bar_limits', 'var_limits', 'col_inf' and 'col_sup', but the behaviour +#' can be manually forced to draw or not to draw the triangle ends with this +#' parameter. If 'cols' is provided, 'col_inf' and 'col_sup' will take +#' priority over 'triangle_ends' when deciding whether to draw the triangle +#' ends or not. +#'@param col_inf Colour to fill the inferior triangle end with. Useful if +#' specifying colours manually with parameter 'cols', to specify the colour +#' and to trigger the drawing of the lower extreme triangle, or if 'cols' is +#' not specified, to replace the colour automatically generated by ColorBar(). +#'@param col_sup Colour to fill the superior triangle end with. Useful if +#' specifying colours manually with parameter 'cols', to specify the colour +#' and to trigger the drawing of the upper extreme triangle, or if 'cols' is +#' not specified, to replace the colour automatically generated by ColorBar(). +#'@param color_fun Function to generate the colours of the color bar. Must +#' take an integer and must return as many colours. The returned colour vector +#' can have the attribute 'na_color', with a colour to draw NA values. This +#' parameter is set by default to clim.palette(). +#'@param plot Logical value indicating whether to only compute its breaks and +#' colours (FALSE) or to also draw it on the current device (TRUE). +#'@param draw_ticks Whether to draw ticks for the labels along the colour bar +#' (TRUE) or not (FALSE). TRUE by default. Disregarded if 'plot = FALSE'. +#'@param draw_separators Whether to draw black lines in the borders of each of +#' the colour rectancles of the colour bar (TRUE) or not (FALSE). FALSE by +#' default. Disregarded if 'plot = FALSE'. +#'@param triangle_ends_scale Scale factor for the drawn triangle ends of the +#' colour bar, if drawn at all. Takes 1 by default (rectangle triangle +#' proportional to the thickness of the colour bar). Disregarded if +#' 'plot = FALSE'. +#'@param extra_labels Numeric vector of extra labels to draw along axis of +#' the colour bar. The number of provided decimals will be conserved. +#' Disregarded if 'plot = FALSE'. +#'@param title Title to draw on top of the colour bar, most commonly with the +#' units of the represented field in the neighbour figures. Empty by default. +#'@param title_scale Scale factor for the 'title' of the colour bar. +#' Takes 1 by default. +#'@param label_scale Scale factor for the labels of the colour bar. +#' Takes 1 by default. +#'@param tick_scale Scale factor for the length of the ticks of the labels +#' along the colour bar. Takes 1 by default. +#'@param extra_margin Extra margins to be added around the colour bar, +#' in the format c(y1, x1, y2, x2). The units are margin lines. Takes +#' rep(0, 4) by default. +#'@param label_digits Number of significant digits to be displayed in the +#' labels of the colour bar, usually to avoid too many decimal digits +#' overflowing the figure region. This does not have effect over the labels +#' provided in 'extra_labels'. Takes 4 by default. +#'@param ... Arguments to be passed to the method. Only accepts the following +#' graphical parameters:\cr adj ann ask bg bty cex.lab cex.main cex.sub cin +#' col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig fin +#' font font.axis font.lab font.main font.sub lend lheight ljoin lmitre lty +#' lwd mai mex mfcol mfrow mfg mkh oma omd omi page pch pin plt pty smo srt +#' tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog.\cr For more +#' information about the parameters see `par`. +#' +#'@return +#'\item{brks}{ +#' Breaks used for splitting the range in intervals. +#'} +#'\item{cols}{ +#' Colours generated for each of the length(brks) - 1 intervals. +#' Always of length length(brks) - 1. +#'} +#'\item{col_inf}{ +#' Colour used to draw the lower triangle end in the colour +#' bar (NULL if not drawn at all). +#'} +#'\item{col_sup}{ +#' Colour used to draw the upper triangle end in the colour +#' bar (NULL if not drawn at all). +#'} +#' +#'@keywords hplot +#'@author History:\cr +#' 0.1 - 2012-04 (V. Guemas, \email{virginie.guemas@@bsc.es}) - Original code\cr +#' 0.2 - 2013-04 (I. Andreu-Burillo, \email{isabel.andreu-burillo@@bsc.es}) - Vert option\cr +#' 1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Formatting to CRAN\cr +#' 1.1 - 2013-09 (C. Prodhomme, \email{chloe.prodhomme@@bsc.es}) - Add cex option\cr +#' 1.2 - 2016-08 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - New ColorBar\cr +#' (V. Torralba, \email{veronica.torralba@@bsc.es}) +#'@examples +#'cols <- c("dodgerblue4", "dodgerblue1", "forestgreen", "yellowgreen", "white", +#' "white", "yellow", "orange", "red", "saddlebrown") +#'lims <- seq(-1, 1, 0.2) +#'ColorBar(lims, cols) +#'@importFrom grDevices col2rgb rgb +#'@export +ColorBar <- function(brks = NULL, cols = NULL, vertical = TRUE, + subsampleg = NULL, bar_limits = NULL, var_limits = NULL, + triangle_ends = NULL, col_inf = NULL, col_sup = NULL, + color_fun = clim.palette(), plot = TRUE, + draw_ticks = TRUE, draw_separators = FALSE, + triangle_ends_scale = 1, extra_labels = NULL, + title = NULL, title_scale = 1, + label_scale = 1, tick_scale = 1, + extra_margin = rep(0, 4), label_digits = 4, ...) { + # Required checks + if ((is.null(brks) || length(brks) < 2) && is.null(bar_limits) && is.null(var_limits)) { + stop("At least one of 'brks' with the desired breaks, 'bar_limits' or ", + "'var_limits' must be provided to generate the colour bar.") + } + + # Check brks + if (!is.null(brks)) { + if (!is.numeric(brks)) { + stop("Parameter 'brks' must be numeric if specified.") + } else if (length(brks) > 1) { + reorder <- sort(brks, index.return = TRUE) + if (!is.null(cols)) { + cols <- cols[reorder$ix[which(reorder$ix <= length(cols))]] + } + brks <- reorder$x + } + } + + # Check bar_limits + if (!is.null(bar_limits)) { + if (!(all(is.na(bar_limits) | is.numeric(bar_limits)) && (length(bar_limits) == 2))) { + stop("Parameter 'bar_limits' must be a vector of two numeric elements or NAs.") + } + } + + # Check var_limits + if (!is.null(var_limits)) { + if (!(is.numeric(var_limits) && (length(var_limits) == 2))) { + stop("Parameter 'var_limits' must be a numeric vector of length 2.") + } else if (any(is.na(var_limits))) { + stop("Parameter 'var_limits' must not contain NA values.") + } else if (any(is.infinite(var_limits))) { + stop("Parameter 'var_limits' must not contain infinite values.") + } + } + + # Check cols + if (!is.null(cols)) { + if (!is.character(cols)) { + stop("Parameter 'cols' must be a vector of character strings.") + } else if (any(!sapply(cols, .IsColor))) { + stop("Parameter 'cols' must contain valid colour identifiers.") + } + } + + # Check color_fun + if (!is.function(color_fun)) { + stop("Parameter 'color_fun' must be a colour-generator function.") + } + + # Check integrity among brks, bar_limits and var_limits + if (is.null(brks) || (length(brks) < 2)) { + if (is.null(brks)) { + if (is.null(cols)) { + brks <- 21 + } else { + brks <- length(cols) + 1 + } + } + if (is.null(bar_limits) || any(is.na(bar_limits))) { + # var_limits is defined + if (is.null(bar_limits)) { + bar_limits <- c(NA, NA) + } + half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1) + bar_limits[which(is.na(bar_limits))] <- c(var_limits[1] - half_width, var_limits[2] + half_width)[which(is.na(bar_limits))] + brks <- seq(bar_limits[1], bar_limits[2], length.out = brks) + } else if (is.null(var_limits)) { + # bar_limits is defined + var_limits <- bar_limits + half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (brks - 1) + brks <- seq(bar_limits[1], bar_limits[2], length.out = brks) + var_limits[1] <- var_limits[1] + half_width / 50 + } else { + # both bar_limits and var_limits are defined + brks <- seq(bar_limits[1], bar_limits[2], length.out = brks) + } + } else if (is.null(bar_limits)) { + if (is.null(var_limits)) { + # brks is defined + bar_limits <- c(head(brks, 1), tail(brks, 1)) + var_limits <- bar_limits + half_width <- 0.5 * (var_limits[2] - var_limits[1]) / (length(brks) - 1) + var_limits[1] <- var_limits[1] + half_width / 50 + } else { + # brks and var_limits are defined + bar_limits <- c(head(brks, 1), tail(brks, 1)) + } + } else { + # brks and bar_limits are defined + # or + # brks, bar_limits and var_limits are defined + if (head(brks, 1) != bar_limits[1] || tail(brks, 1) != bar_limits[2]) { + stop("Parameters 'brks' and 'bar_limits' are inconsistent.") + } + } + + # Check col_inf + if (!is.null(col_inf)) { + if (!.IsColor(col_inf)) { + stop("Parameter 'col_inf' must be a valid colour identifier.") + } + } + + # Check col_sup + if (!is.null(col_sup)) { + if (!.IsColor(col_sup)) { + stop("Parameter 'col_sup' must be a valid colour identifier.") + } + } + + # Check triangle_ends + if (!is.null(triangle_ends) && (!is.logical(triangle_ends) || length(triangle_ends) != 2)) { + stop("Parameter 'triangle_ends' must be a logical vector with two elements.") + } + teflc <- triangle_ends_from_limit_cols <- c(!is.null(col_inf), !is.null(col_sup)) + if (is.null(triangle_ends) && is.null(col_inf) && is.null(col_sup)) { + triangle_ends <- c(FALSE, FALSE) + if (bar_limits[1] >= var_limits[1]) { + triangle_ends[1] <- TRUE + } + if (bar_limits[2] < var_limits[2]) { + triangle_ends[2] <- TRUE + } + } else if (!is.null(triangle_ends) && is.null(col_inf) && is.null(col_sup)) { + triangle_ends <- triangle_ends + } else if (is.null(triangle_ends) && (!is.null(col_inf) || !is.null(col_sup))) { + triangle_ends <- teflc + } else if (any(teflc != triangle_ends)) { + if (!is.null(brks) && length(brks) > 1 && !is.null(cols) && length(cols) >= length(brks)) { + triangle_ends <- teflc + } else if (!is.null(cols)) { + triangle_ends <- teflc + } else { + triangle_ends <- triangle_ends + } + } + if (plot) { + if ((bar_limits[1] >= var_limits[1]) && !triangle_ends[1]) { + .warning("There are variable values smaller or equal to the lower limit ", + "of the colour bar and the lower triangle end has been ", + "disabled. These will be painted in the colour for NA values.") + } + if ((bar_limits[2] < var_limits[2]) && !triangle_ends[2]) { + .warning("There are variable values greater than the higher limit ", + "of the colour bar and the higher triangle end has been ", + "disabled. These will be painted in the colour for NA values.") + } + } + + # Generate colours if needed + if (is.null(cols)) { + cols <- color_fun(length(brks) - 1 + sum(triangle_ends)) + attr_bk <- attributes(cols) + if (triangle_ends[1]) { + if (is.null(col_inf)) col_inf <- head(cols, 1) + cols <- cols[-1] + } + if (triangle_ends[2]) { + if (is.null(col_sup)) col_sup <- tail(cols, 1) + cols <- cols[-length(cols)] + } + attributes(cols) <- attr_bk + } else if ((length(cols) != (length(brks) - 1))) { + stop("Incorrect number of 'brks' and 'cols'. There must be one more break than the number of colours.") + } + + # Check vertical + if (!is.logical(vertical)) { + stop("Parameter 'vertical' must be TRUE or FALSE.") + } + + # Check extra_labels + if (is.null(extra_labels)) { + extra_labels <- numeric(0) + } + if (!is.numeric(extra_labels)) { + stop("Parameter 'extra_labels' must be numeric.") + } else { + if (any(extra_labels > bar_limits[2]) || any(extra_labels < bar_limits[1])) { + stop("Parameter 'extra_labels' must not contain ticks beyond the color bar limits.") + } + } + extra_labels <- sort(extra_labels) + + # Check subsampleg + primes <- function(x) { + # Courtesy of Chase. See http://stackoverflow.com/questions/6424856/r-function-for-returning-all-factors + x <- as.integer(x) + div <- seq_len(abs(x)) + factors <- div[x %% div == 0L] + factors <- list(neg = -factors, pos = factors) + return(factors) + } + remove_final_tick <- FALSE + added_final_tick <- TRUE + if (is.null(subsampleg)) { + subsampleg <- 1 + while (length(brks) / subsampleg > 15 - 1) { + next_factor <- primes((length(brks) - 1) / subsampleg)$pos + next_factor <- next_factor[length(next_factor) - ifelse(length(next_factor) > 2, 1, 0)] + subsampleg <- subsampleg * next_factor + } + if (subsampleg > (length(brks) - 1) / 4) { + subsampleg <- max(1, round(length(brks) / 4)) + extra_labels <- c(extra_labels, bar_limits[2]) + added_final_tick <- TRUE + if ((length(brks) - 1) %% subsampleg < (length(brks) - 1) / 4 / 2) { + remove_final_tick <- TRUE + } + } + } else if (!is.numeric(subsampleg)) { + stop("Parameter 'subsampleg' must be numeric.") + } + subsampleg <- round(subsampleg) + draw_labels <- TRUE + if ((subsampleg) < 1) { + draw_labels <- FALSE + } + + # Check plot + if (!is.logical(plot)) { + stop("Parameter 'plot' must be logical.") + } + + # Check draw_separators + if (!is.logical(draw_separators)) { + stop("Parameter 'draw_separators' must be logical.") + } + + # Check triangle_ends_scale + if (!is.numeric(triangle_ends_scale)) { + stop("Parameter 'triangle_ends_scale' must be numeric.") + } + + # Check draw_ticks + if (!is.logical(draw_ticks)) { + stop("Parameter 'draw_ticks' must be logical.") + } + + # Check title + if (is.null(title)) { + title <- '' + } + if (!is.character(title)) { + stop("Parameter 'title' must be a character string.") + } + + # Check title_scale + if (!is.numeric(title_scale)) { + stop("Parameter 'title_scale' must be numeric.") + } + + # Check label_scale + if (!is.numeric(label_scale)) { + stop("Parameter 'label_scale' must be numeric.") + } + + # Check tick_scale + if (!is.numeric(tick_scale)) { + stop("Parameter 'tick_scale' must be numeric.") + } + + # Check extra_margin + if (!is.numeric(extra_margin) || length(extra_margin) != 4) { + stop("Parameter 'extra_margin' must be a numeric vector of length 4.") + } + + # Check label_digits + if (!is.numeric(label_digits)) { + stop("Parameter 'label_digits' must be numeric.") + } + label_digits <- round(label_digits) + + # Process the user graphical parameters that may be passed in the call + ## Graphical parameters to exclude + excludedArgs <- c("cex", "cex.axis", "col", "lab", "las", "mar", "mgp", "new", "ps") + userArgs <- .FilterUserGraphicArgs(excludedArgs, ...) + + # + # Plotting colorbar + # ~~~~~~~~~~~~~~~~~~~ + # + if (plot) { + pars_to_save <- c('mar', 'cex', names(userArgs), 'mai', 'mgp', 'las', 'xpd') + saved_pars <- par(pars_to_save) + par(mar = c(0, 0, 0, 0), cex = 1) + image(1, 1, t(t(1)), col = rgb(0, 0, 0, 0), axes = FALSE, xlab = '', ylab = '') + # Get the availale space + figure_size <- par('fin') + cs <- par('csi') + # This allows us to assume we always want to plot horizontally + if (vertical) { + figure_size <- rev(figure_size) + } +# pannel_to_redraw <- par('mfg') +# .SwitchToFigure(pannel_to_redraw[1], pannel_to_redraw[2]) + # Load the user parameters + par(new = TRUE) + par(userArgs) + # Set up color bar plot region + margins <- c(0.0, 0, 0.0, 0) + cex_title <- 1 * title_scale + cex_labels <- 0.9 * label_scale + cex_ticks <- -0.3 * tick_scale + spaceticklab <- max(-cex_ticks, 0) + if (vertical) { + margins[1] <- margins[1] + (1.2 * cex_labels * 3 + spaceticklab) * cs + margins <- margins + extra_margin[c(4, 1:3)] * cs + } else { + margins[1] <- margins[1] + (1.2 * cex_labels * 1 + spaceticklab) * cs + margins <- margins + extra_margin * cs + } + if (title != '') { + margins[3] <- margins[3] + (1.0 * cex_title) * cs + } + margins[3] <- margins[3] + sqrt(figure_size[2] / (margins[1] + margins[3])) * + figure_size[2] / 6 * ifelse(title != '', 0.5, 0.8) + # Set side margins + margins[2] <- margins[2] + figure_size[1] / 16 + margins[4] <- margins[4] + figure_size[1] / 16 + triangle_ends_prop <- 1 / 32 * triangle_ends_scale + triangle_ends_cex <- triangle_ends_prop * figure_size[2] + if (triangle_ends[1]) { + margins[2] <- margins[2] + triangle_ends_cex + } + if (triangle_ends[2]) { + margins[4] <- margins[4] + triangle_ends_cex + } + ncols <- length(cols) + # Set up the points of triangles + # Compute the proportion of horiz. space occupied by one plot unit + prop_unit <- (1 - (margins[2] + margins[4]) / figure_size[1]) / ncols + # Convert triangle height to plot inits + triangle_height <- triangle_ends_prop / prop_unit + left_triangle <- list(x = c(1, 1 - triangle_height, 1) - 0.5, + y = c(1.4, 1, 0.6)) + right_triangle <- list(x = c(ncols, ncols + triangle_height, ncols) + 0.5, + y = c(1.4, 1, 0.6)) + # Draw the color squares and title + if (vertical) { + par(mai = c(margins[2:4], margins[1]), + mgp = c(0, spaceticklab + 0.2, 0), las = 1) + d <- 4 + image(1, 1:ncols, t(1:ncols), axes = FALSE, col = cols, + xlab = '', ylab = '') + title(ylab = title, line = cex_title * (0.2 + 0.1), cex.lab = cex_title) + # Draw top and bottom border lines + lines(c(0.6, 0.6), c(1 - 0.5, ncols + 0.5)) + lines(c(1.4, 1.4), c(1 - 0.5, ncols + 0.5)) + # Rotate triangles + names(left_triangle) <- rev(names(left_triangle)) + names(right_triangle) <- rev(names(right_triangle)) + } else { + # The term - cex_labels / 4 * (3 / cex_labels - 1) was found by + # try and error + par(mai = margins, + mgp = c(0, cex_labels / 2 + spaceticklab + - cex_labels / 4 * (3 / cex_labels - 1), 0), + las = 1) + d <- 1 + image(1:ncols, 1, t(t(1:ncols)), axes = FALSE, col = cols, + xlab = '', ylab = '') + title(title, line = cex_title * (0.2 + 0.1), cex.main = cex_title) + # Draw top and bottom border lines + lines(c(1 - 0.5, ncols + 0.5), c(0.6, 0.6)) + lines(c(1 - 0.5, ncols + 0.5), c(1.4, 1.4)) + tick_length <- -0.4 + } + # Draw the triangles + par(xpd = TRUE) + if (triangle_ends[1]) { + # Draw left triangle + polygon(left_triangle$x, left_triangle$y, col = col_inf, border = NA) + lines(left_triangle$x, left_triangle$y) + } + if (triangle_ends[2]) { + # Draw right triangle + polygon(right_triangle$x, right_triangle$y, col = col_sup, border = NA) + lines(right_triangle$x, right_triangle$y) + } + par(xpd = FALSE) + + # Put the separators + if (vertical) { + if (draw_separators) { + for (i in 1:(ncols - 1)) { + lines(c(0.6, 1.4), c(i, i) + 0.5) + } + } + if (draw_separators || is.null(col_inf)) { + lines(c(0.6, 1.4), c(0.5, 0.5)) + } + if (draw_separators || is.null(col_sup)) { + lines(c(0.6, 1.4), c(ncols + 0.5, ncols + 0.5)) + } + } else { + if (draw_separators) { + for (i in 1:(ncols - 1)) { + lines(c(i, i) + 0.5, c(0.6, 1.4)) + } + } + if (draw_separators || is.null(col_inf)) { + lines(c(0.5, 0.5), c(0.6, 1.4)) + } + if (draw_separators || is.null(col_sup)) { + lines(c(ncols + 0.5, ncols + 0.5), c(0.6, 1.4)) + } + } + # Put the ticks + plot_range <- length(brks) - 1 + var_range <- tail(brks, 1) - head(brks, 1) + extra_labels_at <- ((extra_labels - head(brks, 1)) / var_range) * plot_range + 0.5 + at <- seq(1, length(brks), subsampleg) + labels <- brks[at] + # Getting rid of next-to-last tick if too close to last one + if (remove_final_tick) { + at <- at[-length(at)] + labels <- labels[-length(labels)] + } + labels <- signif(labels, label_digits) + if (added_final_tick) { + extra_labels[length(extra_labels)] <- signif(tail(extra_labels, 1), label_digits) + } + at <- at - 0.5 + at <- c(at, extra_labels_at) + labels <- c(labels, extra_labels) + tick_reorder <- sort(at, index.return = TRUE) + at <- tick_reorder$x + if (draw_labels) { + labels <- labels[tick_reorder$ix] + } else { + labels <- FALSE + } + axis(d, at = at, tick = draw_ticks, labels = labels, cex.axis = cex_labels, tcl = cex_ticks) + par(saved_pars) + } + invisible(list(brks = brks, cols = cols, col_inf = col_inf, col_sup = col_sup)) +} diff --git a/R/LeapYear.R b/R/LeapYear.R new file mode 100644 index 0000000..8986560 --- /dev/null +++ b/R/LeapYear.R @@ -0,0 +1,36 @@ +#'Checks Whether A Year Is Leap Year +#' +#'This function tells whether a year is a leap year or not. +#' +#'@param year A numeric value indicating the year in the Gregorian calendar. +#' +#'@return Boolean telling whether the year is a leap year or not. +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-03 (V. Guemas, \email{vguemas@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +#'@examples +#'print(LeapYear(1990)) +#'print(LeapYear(1991)) +#'print(LeapYear(1992)) +#'print(LeapYear(1993)) + +#'@export +LeapYear <- function(year) { + leap <- FALSE + if (year %% 4 == 0) { + leap <- TRUE + if (year %% 100 == 0) { + leap <- FALSE + if (year %% 400 == 0) { + leap <- TRUE + } + } + } + + # + # Output + # + leap +} diff --git a/R/Load.R b/R/Load.R new file mode 100644 index 0000000..cded956 --- /dev/null +++ b/R/Load.R @@ -0,0 +1,2321 @@ +#'Loads Experimental And Observational Data +#' +#'This function loads monthly or daily data from a set of specified +#'experimental datasets together with data that date-corresponds from a set +#'of specified observational datasets. See parameters 'storefreq', +#''sampleperiod', 'exp' and 'obs'.\cr\cr +#'A set of starting dates is specified through the parameter 'sdates'. Data of +#'each starting date is loaded for each model. +#'\code{Load()} arranges the data in two arrays with a similar format both +#'with the following dimensions: +#' \enumerate{ +#' \item{The number of experimental datasets determined by the user through +#' the argument 'exp' (for the experimental data array) or the number of +#' observational datasets available for validation (for the observational +#' array) determined as well by the user through the argument 'obs'.} +#' \item{The greatest number of members across all experiments (in the +#' experimental data array) or across all observational datasets (in the +#' observational data array).} +#' \item{The number of starting dates determined by the user through the +#' 'sdates' argument.} +#' \item{The greatest number of lead-times.} +#' \item{The number of latitudes of the selected zone.} +#' \item{The number of longitudes of the selected zone.} +#' } +#'Dimensions 5 and 6 are optional and their presence depends on the type of +#'the specified variable (global mean or 2-dimensional) and on the selected +#'output type (area averaged time series, latitude averaged time series, +#'longitude averaged time series or 2-dimensional time series).\cr +#'In the case of loading an area average the dimensions of the arrays will be +#'only the first 4.\cr\cr +#'Only a specified variable is loaded from each experiment at each starting +#'date. See parameter 'var'.\cr +#'Afterwards, observational data that matches every starting date and lead-time +#'of every experimental dataset is fetched in the file system (so, if two +#'predictions at two different start dates overlap, some observational values +#'will be loaded and kept in memory more than once).\cr +#'If no data is found in the file system for an experimental or observational +#'array point it is filled with an NA value.\cr\cr +#'If the specified output is 2-dimensional or latitude- or longitude-averaged +#'time series all the data is interpolated into a common grid. If the +#'specified output type is area averaged time series the data is averaged on +#'the individual grid of each dataset but can also be averaged after +#'interpolating into a common grid. See parameters 'grid' and 'method'.\cr +#'Once the two arrays are filled by calling this function, other functions in +#'the s2dverification package that receive as inputs data formatted in this +#'data structure can be executed (e.g: \code{Clim()} to compute climatologies, +#'\code{Ano()} to compute anomalies, ...).\cr\cr +#'Load() has many additional parameters to disable values and trim dimensions +#'of selected variable, even masks can be applied to 2-dimensional variables. +#'See parameters 'nmember', 'nmemberobs', 'nleadtime', 'leadtimemin', +#''leadtimemax', 'sampleperiod', 'lonmin', 'lonmax', 'latmin', 'latmax', +#''maskmod', 'maskobs', 'varmin', 'varmax'.\cr\cr +#'The parameters 'exp' and 'obs' can take various forms. The most direct form +#'is a list of lists, where each sub-list has the component 'path' associated +#'to a character string with a pattern of the path to the files of a dataset +#'to be loaded. These patterns can contain wildcards and tags that will be +#'replaced automatically by \code{Load()} with the specified starting dates, +#'member numbers, variable name, etc.\cr +#'See parameter 'exp' or 'obs' for details.\cr\cr +#'Only NetCDF files are supported. OPeNDAP URLs to NetCDF files are also +#'supported.\cr +#'\code{Load()} can load 2-dimensional or global mean variables in any of the +#'following formats: +#' \itemize{ +#' \item{experiments: +#' \itemize{ +#' \item{file per ensemble per starting date +#' (YYYY, MM and DD somewhere in the path)} +#' \item{file per member per starting date +#' (YYYY, MM, DD and MemberNumber somewhere in the path. Ensemble +#' experiments with different numbers of members can be loaded in +#' a single \code{Load()} call.)} +#' } +#' (YYYY, MM and DD specify the starting dates of the predictions) +#' } +#' \item{observations: +#' \itemize{ +#' \item{file per ensemble per month +#' (YYYY and MM somewhere in the path)} +#' \item{file per member per month +#' (YYYY, MM and MemberNumber somewhere in the path, obs with different +#' numbers of members supported)} +#' \item{file per dataset (No constraints in the path but the time axes +#' in the file have to be properly defined)} +#' } +#' (YYYY and MM correspond to the actual month data in the file) +#' } +#' } +#'In all the formats the data can be stored in a daily or monthly frequency, +#'or a multiple of these (see parameters 'storefreq' and 'sampleperiod').\cr +#'All the data files must contain the target variable defined over time and +#'potentially over members, latitude and longitude dimensions in any order, +#'time being the record dimension.\cr +#'In the case of a two-dimensional variable, the variables longitude and +#'latitude must be defined inside the data file too and must have the same +#'names as the dimension for longitudes and latitudes respectively.\cr +#'The names of these dimensions (and longitude and latitude variables) and the +#'name for the members dimension are expected to be 'longitude', 'latitude' +#'and 'ensemble' respectively. However, these names can be adjusted with the +#'parameter 'dimnames' or can be configured in the configuration file (read +#'below in parameters 'exp', 'obs' or see \code{?ConfigFileOpen} +#'for more information.\cr +#'All the data files are expected to have numeric values representable with +#'32 bits. Be aware when choosing the fill values or infinite values in the +#'datasets to load.\cr\cr +#'The Load() function returns a named list following a structure similar to +#'the used in the package 'downscaleR'.\cr +#'The components are the following: +#' \itemize{ +#' \item{'mod' is the array that contains the experimental data. It has the +#' attribute 'dimensions' associated to a vector of strings with the labels +#' of each dimension of the array, in order.} +#' \item{'obs' is the array that contains the observational data. It has +#' the attribute 'dimensions' associated to a vector of strings with the +#' labels of each dimension of the array, in order.} +#' \item{'obs' is the array that contains the observational data.} +#' \item{'lat' and 'lon' are the latitudes and longitudes of the grid into +#' which the data is interpolated (0 if the loaded variable is a global +#' mean or the output is an area average).\cr +#' Both have the attribute 'cdo_grid_des' associated with a character +#' string with the name of the common grid of the data, following the CDO +#' naming conventions for grids.\cr +#' The attribute 'projection' is kept for compatibility with 'downscaleR'. +#' } +#' \item{'Variable' has the following components: +#' \itemize{ +#' \item{'varName', with the short name of the loaded variable as +#' specified in the parameter 'var'.} +#' \item{'level', with information on the pressure level of the variable. +#' Is kept to NULL by now.} +#' } +#' And the following attributes: +#' \itemize{ +#' \item{'is_standard', kept for compatibility with 'downscaleR', +#' tells if a dataset has been homogenized to standards with +#' 'downscaleR' catalogs.} +#' \item{'units', a character string with the units of measure of the +#' variable, as found in the source files.} +#' \item{'longname', a character string with the long name of the +#' variable, as found in the source files.} +#' \item{'daily_agg_cellfun', 'monthly_agg_cellfun', 'verification_time', +#' kept for compatibility with 'downscaleR'.} +#' } +#' } +#' \item{'Datasets' has the following components: +#' \itemize{ +#' \item{'exp', a named list where the names are the identifying +#' character strings of each experiment in 'exp', each associated to a +#' list with the following components: +#' \itemize{ +#' \item{'members', a list with the names of the members of the +#' dataset.} +#' \item{'source', a path or URL to the source of the dataset.} +#' } +#' } +#' \item{'obs', similar to 'exp' but for observational datasets.} +#' } +#' } +#' \item{'Dates', with the follwing components: +#' \itemize{ +#' \item{'start', an array of dimensions (sdate, time) with the POSIX +#' initial date of each forecast time of each starting date.} +#' \item{'end', an array of dimensions (sdate, time) with the POSIX +#' final date of each forecast time of each starting date.} +#' } +#' } +#' \item{'InitializationDates', a vector of starting dates as specified in +#' 'sdates', in POSIX format.} +#' \item{'when', a time stamp of the date the \code{Load()} call to obtain +#' the data was issued.} +#' \item{'source_files', a vector of character strings with complete paths +#' to all the found files involved in the \code{Load()} call.} +#' \item{'not_found_files', a vector of character strings with complete +#' paths to not found files involved in the \code{Load()} call.} +#' } +#' +#'@param var Short name of the variable to load. It should coincide with the +#' variable name inside the data files.\cr +#' E.g.: \code{var = 'tos'}, \code{var = 'tas'}, \code{var = 'prlr'}.\cr +#' In some cases, though, the path to the files contains twice or more times +#' the short name of the variable but the actual name of the variable inside +#' the data files is different. In these cases it may be convenient to provide +#' \code{var} with the name that appears in the file paths (see details on +#' parameters \code{exp} and \code{obs}). +#'@param exp Parameter to specify which experimental datasets to load data +#' from.\cr +#' It can take two formats: a list of lists or a vector of character strings. +#' Each format will trigger a different mechanism of locating the requested +#' datasets.\cr +#' The first format is adequate when loading data you'll only load once or +#' occasionally. The second format is targeted to avoid providing repeatedly +#' the information on a certain dataset but is more complex to use.\cr\cr +#' IMPORTANT: Place first the experiment with the largest number of members +#' and, if possible, with the largest number of leadtimes. If not possible, +#' the arguments 'nmember' and/or 'nleadtime' should be filled to not miss +#' any member or leadtime.\cr +#' If 'exp' is not specified or set to NULL, observational data is loaded for +#' each start-date as far as 'leadtimemax'. If 'leadtimemax' is not provided, +#' \code{Load()} will retrieve data of a period of time as long as the time +#' period between the first specified start date and the current date.\cr\cr +#' List of lists:\cr +#' A list of lists where each sub-list contains information on the location +#' and format of the data files of the dataset to load.\cr +#' Each sub-list can have the following components: +#' \itemize{ +#' \item{'name': A character string to identify the dataset. Optional.} +#' \item{'path': A character string with the pattern of the path to the +#' files of the dataset. This pattern can be built up making use of some +#' special tags that \code{Load()} will replace with the appropriate +#' values to find the dataset files. The allowed tags are $START_DATE$, +#' $YEAR$, $MONTH$, $DAY$, $MEMBER_NUMBER$, $STORE_FREQ$, $VAR_NAME$, +#' $EXP_NAME$ (only for experimental datasets), $OBS_NAME$ (only for +#' observational datasets) and $SUFFIX$\cr +#' Example: /path/to/$EXP_NAME$/postprocessed/$VAR_NAME$/\cr +#' $VAR_NAME$_$START_DATE$.nc\cr +#' If 'path' is not specified and 'name' is specified, the dataset +#' information will be fetched with the same mechanism as when using +#' the vector of character strings (read below). +#' } +#' \item{'nc_var_name': Character string with the actual variable name +#' to look for inside the dataset files. Optional. Takes, by default, +#' the same value as the parameter 'var'. +#' } +#' \item{'suffix': Wildcard character string that can be used to build +#' the 'path' of the dataset. It can be accessed with the tag $SUFFIX$. +#' Optional. Takes '' by default. +#' } +#' \item{'var_min': Important: Character string. Minimum value beyond +#' which read values will be deactivated to NA. Optional. No deactivation +#' is performed by default. +#' } +#' \item{'var_max': Important: Character string. Maximum value beyond +#' which read values will be deactivated to NA. Optional. No deactivation +#' is performed by default. +#' } +#' } +#' The tag $START_DATES$ will be replaced with all the starting dates +#' specified in 'sdates'. $YEAR$, $MONTH$ and $DAY$ will take a value for each +#' iteration over 'sdates', simply these are the same as $START_DATE$ but +#' split in parts.\cr +#' $MEMBER_NUMBER$ will be replaced by a character string with each member +#' number, from 1 to the value specified in the parameter 'nmember' (in +#' experimental datasets) or in 'nmemberobs' (in observational datasets). It +#' will range from '01' to 'N' or '0N' if N < 10.\cr +#' $STORE_FREQ$ will take the value specified in the parameter 'storefreq' +#' ('monthly' or 'daily').\cr +#' $VAR_NAME$ will take the value specified in the parameter 'var'.\cr +#' $EXP_NAME$ will take the value specified in each component of the parameter +#' 'exp' in the sub-component 'name'.\cr +#' $OBS_NAME$ will take the value specified in each component of the parameter +#' 'obs' in the sub-component 'obs.\cr +#' $SUFFIX$ will take the value specified in each component of the parameters +#' 'exp' and 'obs' in the sub-component 'suffix'.\cr +#' Example: +#' \preformatted{ +#' list( +#' list( +#' name = 'experimentA', +#' path = file.path('/path/to/$DATASET_NAME$/$STORE_FREQ$', +#' '$VAR_NAME$$SUFFIX$', +#' '$VAR_NAME$_$START_DATE$.nc'), +#' nc_var_name = '$VAR_NAME$', +#' suffix = '_3hourly', +#' var_min = '-1e19', +#' var_max = '1e19' +#' ) +#' ) +#' } +#' This will make \code{Load()} look for, for instance, the following paths, +#' if 'sdates' is c('19901101', '19951101', '20001101'):\cr +#' /path/to/experimentA/monthly_mean/tas_3hourly/tas_19901101.nc\cr +#' /path/to/experimentA/monthly_mean/tas_3hourly/tas_19951101.nc\cr +#' /path/to/experimentA/monthly_mean/tas_3hourly/tas_20001101.nc\cr\cr +#' Vector of character strings: +#' To avoid specifying constantly the same information to load the same +#' datasets, a vector with only the names of the datasets to load can be +#' specified.\cr +#' \code{Load()} will then look for the information in a configuration file +#' whose path must be specified in the parameter 'configfile'.\cr +#' Check \code{?ConfigFileCreate}, \code{ConfigFileOpen}, +#' \code{ConfigEditEntry} & co. to learn how to create a new configuration +#' file and how to add the information there.\cr +#' Example: c('experimentA', 'experimentB') +#' +#'@param obs Argument with the same format as parameter 'exp'. See details on +#' parameter 'exp'.\cr +#' If 'obs' is not specified or set to NULL, no observational data is loaded.\cr +#'@param sdates Vector of starting dates of the experimental runs to be loaded +#' following the pattern 'YYYYMMDD'.\cr +#' This argument is mandatory.\cr +#' E.g. c('19601101', '19651101', '19701101') +#'@param nmember Vector with the numbers of members to load from the specified +#' experimental datasets in 'exp'.\cr +#' If not specified, the automatically detected number of members of the +#' first experimental dataset is detected and replied to all the experimental +#' datasets.\cr +#' If a single value is specified it is replied to all the experimental +#' datasets.\cr +#' Data for each member is fetched in the file system. If not found is +#' filled with NA values.\cr +#' An NA value in the 'nmember' list is interpreted as "fetch as many members +#' of each experimental dataset as the number of members of the first +#' experimental dataset".\cr +#' Note: It is recommended to specify the number of members of the first +#' experimental dataset if it is stored in file per member format because +#' there are known issues in the automatic detection of members if the path +#' to the dataset in the configuration file contains Shell Globbing wildcards +#' such as '*'.\cr +#' E.g., c(4, 9) +#'@param nmemberobs Vector with the numbers of members to load from the +#' specified observational datasets in 'obs'.\cr +#' If not specified, the automatically detected number of members of the +#' first observational dataset is detected and replied to all the +#' observational datasets.\cr +#' If a single value is specified it is replied to all the observational +#' datasets.\cr +#' Data for each member is fetched in the file system. If not found is +#' filled with NA values.\cr +#' An NA value in the 'nmemberobs' list is interpreted as "fetch as many +#' members of each observational dataset as the number of members of the +#' first observational dataset".\cr +#' Note: It is recommended to specify the number of members of the first +#' observational dataset if it is stored in file per member format because +#' there are known issues in the automatic detection of members if the path +#' to the dataset in the configuration file contains Shell Globbing wildcards +#' such as '*'.\cr +#' E.g., c(1, 5) +#'@param nleadtime Deprecated. See parameter 'leadtimemax'. +#'@param leadtimemin Only lead-times higher or equal to 'leadtimemin' are +#' loaded. Takes by default value 1. +#'@param leadtimemax Only lead-times lower or equal to 'leadtimemax' are loaded. +#' Takes by default the number of lead-times of the first experimental +#' dataset in 'exp'.\cr +#' If 'exp' is NULL this argument won't have any effect +#' (see \code{?Load} description). +#'@param storefreq Frequency at which the data to be loaded is stored in the +#' file system. Can take values 'monthly' or 'daily'.\cr +#' By default it takes 'monthly'.\cr +#' Note: Data stored in other frequencies with a period which is divisible by +#' a month can be loaded with a proper use of 'storefreq' and 'sampleperiod' +#' parameters. It can also be loaded if the period is divisible by a day and +#' the observational datasets are stored in a file per dataset format or +#' 'obs' is empty. +#'@param sampleperiod To load only a subset between 'leadtimemin' and +#' 'leadtimemax' with the period of subsampling 'sampleperiod'.\cr +#' Takes by default value 1 (all lead-times are loaded).\cr +#' See 'storefreq' for more information. +#'@param lonmin If a 2-dimensional variable is loaded, values at longitudes +#' lower than 'lonmin' aren't loaded.\cr +#' Must take a value in the range [-360, 360] (if negative longitudes are +#' found in the data files these are translated to this range).\cr +#' It is set to 0 if not specified.\cr +#' If 'lonmin' > 'lonmax', data across Greenwich is loaded. +#'@param lonmax If a 2-dimensional variable is loaded, values at longitudes +#' higher than 'lonmax' aren't loaded.\cr +#' Must take a value in the range [-360, 360] (if negative longitudes are +#' found in the data files these are translated to this range).\cr +#' It is set to 360 if not specified.\cr +#' If 'lonmin' > 'lonmax', data across Greenwich is loaded. +#'@param latmin If a 2-dimensional variable is loaded, values at latitudes +#' lower than 'latmin' aren't loaded.\cr +#' Must take a value in the range [-90, 90].\cr +#' It is set to -90 if not specified. +#'@param latmax If a 2-dimensional variable is loaded, values at latitudes +#' higher than 'latmax' aren't loaded.\cr +#' Must take a value in the range [-90, 90].\cr +#' It is set to 90 if not specified. +#'@param output This parameter determines the format in which the data is +#' arranged in the output arrays.\cr +#' Can take values 'areave', 'lon', 'lat', 'lonlat'.\cr +#' \itemize{ +#' \item{'areave': Time series of area-averaged variables over the specified domain.} +#' \item{'lon': Time series of meridional averages as a function of longitudes.} +#' \item{'lat': Time series of zonal averages as a function of latitudes.} +#' \item{'lonlat': Time series of 2d fields.} +#' } +#' Takes by default the value 'areave'. If the variable specified in 'var' is +#' a global mean, this parameter is forced to 'areave'.\cr +#' All the loaded data is interpolated into the grid of the first experimental +#' dataset except if 'areave' is selected. In that case the area averages are +#' computed on each dataset original grid. A common grid different than the +#' first experiment's can be specified through the parameter 'grid'. If 'grid' +#' is specified when selecting 'areave' output type, all the loaded data is +#' interpolated into the specified grid before calculating the area averages. +#'@param method This parameter determines the interpolation method to be used +#' when regridding data (see 'output'). Can take values 'bilinear', 'bicubic', +#' 'conservative', 'distance-weighted'.\cr +#' See \code{remapcells} for advanced adjustments.\cr +#' Takes by default the value 'conservative'. +#'@param grid A common grid can be specified through the parameter 'grid' when +#' loading 2-dimensional data. Data is then interpolated onto this grid +#' whichever 'output' type is specified. If the selected output type is +#' 'areave' and a 'grid' is specified, the area averages are calculated after +#' interpolating to the specified grid.\cr +#' If not specified and the selected output type is 'lon', 'lat' or 'lonlat', +#' this parameter takes as default value the grid of the first experimental +#' dataset, which is read automatically from the source files.\cr +#' The grid must be supported by 'cdo' tools. Now only supported: rNXxNY +#' or tTRgrid.\cr +#' Both rNXxNY and tRESgrid yield rectangular regular grids. rNXxNY yields +#' grids that are evenly spaced in longitudes and latitudes (in degrees). +#' tRESgrid refers to a grid generated with series of spherical harmonics +#' truncated at the RESth harmonic. However these spectral grids are usually +#' associated to a gaussian grid, the latitudes of which are spaced with a +#' Gaussian quadrature (not evenly spaced in degrees). The pattern tRESgrid +#' will yield a gaussian grid.\cr +#' E.g., 'r96x72' +#' Advanced: If the output type is 'lon', 'lat' or 'lonlat' and no common +#' grid is specified, the grid of the first experimental or observational +#' dataset is detected and all data is then interpolated onto this grid. +#' If the first experimental or observational dataset's data is found shifted +#' along the longitudes (i.e., there's no value at the longitude 0 but at a +#' longitude close to it), the data is re-interpolated to suppress the shift. +#' This has to be done in order to make sure all the data from all the +#' datasets is properly aligned along longitudes, as there's no option so far +#' in \code{Load} to specify grids starting at longitudes other than 0. +#' This issue doesn't affect when loading in 'areave' mode without a common +#' grid, the data is not re-interpolated in that case. +#'@param maskmod List of masks to be applied to the data of each experimental +#' dataset respectively, if a 2-dimensional variable is specified in 'var'.\cr +#' Each mask can be defined in 2 formats:\cr +#' a) a matrix with dimensions c(longitudes, latitudes).\cr +#' b) a list with the components 'path' and, optionally, 'nc_var_name'.\cr +#' In the format a), the matrix must have the same size as the common grid +#' or with the same size as the grid of the corresponding experimental dataset +#' if 'areave' output type is specified and no common 'grid' is specified.\cr +#' In the format b), the component 'path' must be a character string with the +#' path to a NetCDF mask file, also in the common grid or in the grid of the +#' corresponding dataset if 'areave' output type is specified and no common +#' 'grid' is specified. If the mask file contains only a single variable, +#' there's no need to specify the component 'nc_var_name'. Otherwise it must +#' be a character string with the name of the variable inside the mask file +#' that contains the mask values. This variable must be defined only over 2 +#' dimensions with length greater or equal to 1.\cr +#' Whichever the mask format, a value of 1 at a point of the mask keeps the +#' original value at that point whereas a value of 0 disables it (replaces +#' by a NA value).\cr +#' By default all values are kept (all ones).\cr +#' The longitudes and latitudes in the matrix must be in the same order as in +#' the common grid or as in the original grid of the corresponding dataset +#' when loading in 'areave' mode. You can find out the order of the longitudes +#' and latitudes of a file with 'cdo griddes'.\cr +#' Note that in a common CDO grid defined with the patterns 'tgrid' or +#' 'rx' the latitudes and latitudes are ordered, by definition, from +#' -90 to 90 and from 0 to 360, respectively.\cr +#' If you are loading maps ('lonlat', 'lon' or 'lat' output types) all the +#' data will be interpolated onto the common 'grid'. If you want to specify +#' a mask, you will have to provide it already interpolated onto the common +#' grid (you may use 'cdo' libraries for this purpose). It is not usual to +#' apply different masks on experimental datasets on the same grid, so all +#' the experiment masks are expected to be the same.\cr +#' Warning: When loading maps, any masks defined for the observational data +#' will be ignored to make sure the same mask is applied to the experimental +#' and observational data.\cr +#' Warning: list() compulsory even if loading 1 experimental dataset only!\cr +#' E.g., list(array(1, dim = c(num_lons, num_lats))) +#'@param maskobs See help on parameter 'maskmod'. +#'@param configfile Path to the s2dverification configuration file from which +#' to retrieve information on location in file system (and other) of datasets.\cr +#' If not specified, the configuration file used at BSC-ES will be used +#' (it is included in the package).\cr +#' Check the BSC's configuration file or a template of configuration file in +#' the folder 'inst/config' in the package.\cr +#' Check further information on the configuration file mechanism in +#' \code{ConfigFileOpen()}. +#'@param varmin Loaded experimental and observational data values smaller +#' than 'varmin' will be disabled (replaced by NA values).\cr +#' By default no deactivation is performed. +#'@param varmax Loaded experimental and observational data values greater +#' than 'varmax' will be disabled (replaced by NA values).\cr +#' By default no deactivation is performed. +#'@param silent Parameter to show (FALSE) or hide (TRUE) information messages.\cr +#' Warnings will be displayed even if 'silent' is set to TRUE.\cr +#' Takes by default the value 'FALSE'. +#'@param nprocs Number of parallel processes created to perform the fetch +#' and computation of data.\cr +#' These processes will use shared memory in the processor in which Load() +#' is launched.\cr +#' By default the number of logical cores in the machine will be detected +#' and as many processes as logical cores there are will be created.\cr +#' A value of 1 won't create parallel processes.\cr +#' When running in multiple processes, if an error occurs in any of the +#' processes, a crash message appears in the R session of the original +#' process but no detail is given about the error. A value of 1 will display +#' all error messages in the original and only R session.\cr +#' Note: the parallel process create other blocking processes each time they +#' need to compute an interpolation via 'cdo'. +#'@param dimnames Named list where the name of each element is a generic +#' name of the expected dimensions inside the NetCDF files. These generic +#' names are 'lon', 'lat' and 'member'. 'time' is not needed because it's +#' detected automatically by discard.\cr +#' The value associated to each name is the actual dimension name in the +#' NetCDF file.\cr +#' The variables in the file that contain the longitudes and latitudes of +#' the data (if the data is a 2-dimensional variable) must have the same +#' name as the longitude and latitude dimensions.\cr +#' By default, these names are 'longitude', 'latitude' and 'ensemble. If any +#' of those is defined in the 'dimnames' parameter, it takes priority and +#' overwrites the default value. +#' E.g., list(lon = 'x', lat = 'y') +#' In that example, the dimension 'member' will take the default value 'ensemble'. +#'@param remapcells When loading a 2-dimensional variable, spatial subsets can +#' be requested via \code{lonmin}, \code{lonmax}, \code{latmin} and +#' \code{latmax}. When \code{Load()} obtains the subset it is then +#' interpolated if needed with the method specified in \code{method}.\cr +#' The result of this interpolation can vary if the values surrounding the +#' spatial subset are not present. To better control this process, the width +#' in number of grid cells of the surrounding area to be taken into account +#' can be specified with \code{remapcells}. A value of 0 will take into +#' account no additional cells but will generate less traffic between the +#' storage and the R processes that load data.\cr +#' A value beyond the limits in the data files will be automatically runcated +#' to the actual limit.\cr +#' The default value is 2. +#'@param path_glob_permissive In some cases, when specifying a path pattern +#' (either in the parameters 'exp'/'obs' or in a configuration file) one can +#' specify path patterns that contain shell globbing expressions. Too much +#' freedom in putting globbing expressions in the path patterns can be +#' dangerous and make \code{Load()} find a file in the file system for a +#' start date for a dataset that really does not belong to that dataset. +#' For example, if the file system contains two directories for two different +#' experiments that share a part of their path and the path pattern contains +#' globbing expressions: +#' /experiments/model1/expA/monthly_mean/tos/tos_19901101.nc +#' /experiments/model2/expA/monthly_mean/tos/tos_19951101.nc +#' And the path pattern is used as in the example right below to load data of +#' only the experiment 'expA' of the model 'model1' for the starting dates +#' '19901101' and '19951101', \code{Load()} will undesiredly yield data for +#' both starting dates, even if in fact there is data only for the +#' first one:\cr +#' \code{ +#' expA <- list(path = file.path('/experiments/*/expA/monthly_mean/$VAR_NAME$', +#' '$VAR_NAME$_$START_DATE$.nc') +#' data <- Load('tos', list(expA), NULL, c('19901101', '19951101')) +#' } +#' To avoid these situations, the parameter \code{path_glob_permissive} is +#' set by default to \code{'partial'}, which forces \code{Load()} to replace +#' all the globbing expressions of a path pattern of a data set by fixed +#' values taken from the path of the first found file for each data set, up +#' to the folder right before the final files (globbing expressions in the +#' file name will not be replaced, only those in the path to the file). +#' Replacement of globbing expressions in the file name can also be triggered +#' by setting \code{path_glob_permissive} to \code{FALSE} or \code{'no'}. If +#' needed to keep all globbing expressions, \code{path_glob_permissive} can +#' be set to \code{TRUE} or \code{'yes'}. +#' +#'@details +#'The two output matrices have between 2 and 6 dimensions:\cr +#' \enumerate{ +#' \item{Number of experimental/observational datasets.} +#' \item{Number of members.} +#' \item{Number of startdates.} +#' \item{Number of leadtimes.} +#' \item{Number of latitudes (optional).} +#' \item{Number of longitudes (optional).} +#' } +#'but the two matrices have the same number of dimensions and only the first +#'two dimensions can have different lengths depending on the input arguments. +#'For a detailed explanation of the process, read the documentation attached +#'to the package or check the comments in the code. +#' +#'@return +#'\code{Load()} returns a named list following a structure similar to the +#'used in the package 'downscaleR'.\cr +#'The components are the following: +#' \itemize{ +#' \item{ +#' 'mod' is the array that contains the experimental data. It has the +#' attribute 'dimensions' associated to a vector of strings with the +#' labels of each dimension of the array, in order. The order of the +#' latitudes is always forced to be from 90 to -90 whereas the order of +#' the longitudes is kept as in the original files (if possible). The +#' longitude values provided in \code{lon} lower than 0 are added 360 +#' (but still kept in the original order). In some cases, however, if +#' multiple data sets are loaded in longitude-latitude mode, the +#' longitudes (and also the data arrays in \code{mod} and \code{obs}) are +#' re-ordered afterwards by \code{Load()} to range from 0 to 360; a +#' warning is given in such cases. The longitude and latitude of the +#' center of the grid cell that corresponds to the value [j, i] in 'mod' +#' (along the dimensions latitude and longitude, respectively) can be +#' found in the outputs \code{lon}[i] and \code{lat}[j] +#' } +#' \item{'obs' is the array that contains the observational data. The +#' same documentation of parameter 'mod' applies to this parameter.} +#' \item{'lat' and 'lon' are the latitudes and longitudes of the centers of +#' the cells of the grid the data is interpolated into (0 if the loaded +#' variable is a global mean or the output is an area average).\cr +#' Both have the attribute 'cdo_grid_des' associated with a character +#' string with the name of the common grid of the data, following the CDO +#' naming conventions for grids.\cr +#' 'lon' has the attributes 'first_lon' and 'last_lon', with the first +#' and last longitude values found in the region defined by 'lonmin' and +#' 'lonmax'. 'lat' has also the equivalent attributes 'first_lat' and +#' 'last_lat'.\cr +#' 'lon' has also the attribute 'data_across_gw' which tells whether the +#' requested region via 'lonmin', 'lonmax', 'latmin', 'latmax' goes across +#' the Greenwich meridian. As explained in the documentation of the +#' parameter 'mod', the loaded data array is kept in the same order as in +#' the original files when possible: this means that, in some cases, even +#' if the data goes across the Greenwich, the data array may not go +#' across the Greenwich. The attribute 'array_across_gw' tells whether +#' the array actually goes across the Greenwich. E.g: The longitudes in +#' the data files are defined to be from 0 to 360. The requested +#' longitudes are from -80 to 40. The original order is kept, hence the +#' longitudes in the array will be ordered as follows: +#' 0, ..., 40, 280, ..., 360. In that case, 'data_across_gw' will be TRUE +#' and 'array_across_gw' will be FALSE.\cr +#' The attribute 'projection' is kept for compatibility with 'downscaleR'. +#' } +#' \item{'Variable' has the following components: +#' \itemize{ +#' \item{'varName', with the short name of the loaded variable as +#' specified in the parameter 'var'. +#' } +#' \item{'level', with information on the pressure level of the +#' variable. Is kept to NULL by now. +#' } +#' } +#' And the following attributes: +#' \itemize{ +#' \item{'is_standard', kept for compatibility with 'downscaleR', +#' tells if a dataset has been homogenized to standards with +#' 'downscaleR' catalogs. +#' } +#' \item{'units', a character string with the units of measure of the +#' variable, as found in the source files. +#' } +#' \item{'longname', a character string with the long name of the +#' variable, as found in the source files. +#' } +#' \item{'daily_agg_cellfun', 'monthly_agg_cellfun', +#' 'verification_time', kept for compatibility with 'downscaleR'. +#' } +#' } +#' } +#' \item{'Datasets' has the following components: +#' \itemize{ +#' \item{'exp', a named list where the names are the identifying +#' character strings of each experiment in 'exp', each associated to +#' a list with the following components: +#' \itemize{ +#' \item{'members', a list with the names of the members of the dataset.} +#' \item{'source', a path or URL to the source of the dataset.} +#' } +#' } +#' \item{'obs', similar to 'exp' but for observational datasets.} +#' } +#' } +#' \item{'Dates', with the follwing components: +#' \itemize{ +#' \item{'start', an array of dimensions (sdate, time) with the POSIX +#' initial date of each forecast time of each starting date. +#' } +#' \item{'end', an array of dimensions (sdate, time) with the POSIX +#' final date of each forecast time of each starting date. +#' } +#' } +#' } +#' \item{'InitializationDates', a vector of starting dates as specified in +#' 'sdates', in POSIX format. +#' } +#' \item{'when', a time stamp of the date the \code{Load()} call to obtain +#' the data was issued. +#' } +#' \item{'source_files', a vector of character strings with complete paths +#' to all the found files involved in the \code{Load()} call. +#' } +#' \item{'not_found_files', a vector of character strings with complete +#' paths to not found files involved in the \code{Load()} call. +#' } +#' } +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@bsc.es}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to CRAN\cr +#'1.2 - 2015-02 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Generalisation + parallelisation\cr +#'1.3 - 2015-07 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Improvements related to configuration file mechanism\cr +#'1.4 - 2016-01 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Added subsetting capabilities +#'@examples +#'# Let's assume we want to perform verification with data of a variable +#'# called 'tos' from a model called 'model' and observed data coming from +#'# an observational dataset called 'observation'. +#'# +#'# The model was run in the context of an experiment named 'experiment'. +#'# It simulated from 1st November in 1985, 1990, 1995, 2000 and 2005 for a +#'# period of 5 years time from each starting date. 5 different sets of +#'# initial conditions were used so an ensemble of 5 members was generated +#'# for each starting date. +#'# The model generated values for the variables 'tos' and 'tas' in a +#'# 3-hourly frequency but, after some initial post-processing, it was +#'# averaged over every month. +#'# The resulting monthly average series were stored in a file for each +#'# starting date for each variable with the data of the 5 ensemble members. +#'# The resulting directory tree was the following: +#'# model +#'# |--> experiment +#'# |--> monthly_mean +#'# |--> tos_3hourly +#'# | |--> tos_19851101.nc +#'# | |--> tos_19901101.nc +#'# | . +#'# | . +#'# | |--> tos_20051101.nc +#'# |--> tas_3hourly +#'# |--> tas_19851101.nc +#'# |--> tas_19901101.nc +#'# . +#'# . +#'# |--> tas_20051101.nc +#'# +#'# The observation recorded values of 'tos' and 'tas' at each day of the +#'# month over that period but was also averaged over months and stored in +#'# a file per month. The directory tree was the following: +#'# observation +#'# |--> monthly_mean +#'# |--> tos +#'# | |--> tos_198511.nc +#'# | |--> tos_198512.nc +#'# | |--> tos_198601.nc +#'# | . +#'# | . +#'# | |--> tos_201010.nc +#'# |--> tas +#'# |--> tas_198511.nc +#'# |--> tas_198512.nc +#'# |--> tas_198601.nc +#'# . +#'# . +#'# |--> tas_201010.nc +#'# +#'# The model data is stored in a file-per-startdate fashion and the +#'# observational data is stored in a file-per-month, and both are stored in +#'# a monthly frequency. The file format is NetCDF. +#'# Hence all the data is supported by Load() (see details and other supported +#'# conventions in ?Load) but first we need to configure it properly. +#'# +#'# These data files are included in the package (in the 'sample_data' folder), +#'# only for the variable 'tos'. They have been interpolated to a very low +#'# resolution grid so as to make it on CRAN. +#'# The original grid names (following CDO conventions) for experimental and +#'# observational data were 't106grid' and 'r180x89' respectively. The final +#'# resolutions are 'r20x10' and 'r16x8' respectively. +#'# The experimental data comes from the decadal climate prediction experiment +#'# run at IC3 in the context of the CMIP5 project. Its name within IC3 local +#'# database is 'i00k'. +#'# The observational dataset used for verification is the 'ERSST' +#'# observational dataset. +#'# +#'# The next two examples are equivalent and show how to load the variable +#'# 'tos' from these sample datasets, the first providing lists of lists to +#'# the parameters 'exp' and 'obs' (see documentation on these parameters) and +#'# the second providing vectors of character strings, hence using a +#'# configuration file. +#'# +#'# The code is not run because it dispatches system calls to 'cdo' which is +#'# not allowed in the examples as per CRAN policies. You can run it on your +#'# system though. +#'# Instead, the code in 'dontshow' is run, which loads the equivalent +#'# already processed data in R. +#'# +#'# Example 1: Providing lists of lists to 'exp' and 'obs': +#'# +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'exp <- list( +#' name = 'experiment', +#' path = file.path(data_path, 'model/$EXP_NAME$/monthly_mean', +#' '$VAR_NAME$_3hourly/$VAR_NAME$_$START_DATES$.nc') +#' ) +#'obs <- list( +#' name = 'observation', +#' path = file.path(data_path, 'observation/$OBS_NAME$/monthly_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(exp), list(obs), startDates, +#' output = 'areave', latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#'# +#'# Example 2: Providing vectors of character strings to 'exp' and 'obs' +#'# and using a configuration file. +#'# +#'# The configuration file 'sample.conf' that we will create in the example +#'# has the proper entries to load these (see ?LoadConfigFile for details on +#'# writing a configuration file). +#'# +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' output = 'areave', latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#'# +#'# Example 2: providing character strings in 'exp' and 'obs', and providing +#'# a configuration file. +#'# The configuration file 'sample.conf' that we will create in the example +#'# has the proper entries to load these (see ?LoadConfigFile for details on +#'# writing a configuration file). +#'# +#'configfile <- paste0(tempdir(), '/sample.conf') +#'ConfigFileCreate(configfile, confirm = FALSE) +#'c <- ConfigFileOpen(configfile) +#'c <- ConfigEditDefinition(c, 'DEFAULT_VAR_MIN', '-1e19', confirm = FALSE) +#'c <- ConfigEditDefinition(c, 'DEFAULT_VAR_MAX', '1e19', confirm = FALSE) +#'data_path <- system.file('sample_data', package = 's2dverification') +#'exp_data_path <- paste0(data_path, '/model/$EXP_NAME$/') +#'obs_data_path <- paste0(data_path, '/$OBS_NAME$/') +#'c <- ConfigAddEntry(c, 'experiments', dataset_name = 'experiment', +#' var_name = 'tos', main_path = exp_data_path, +#' file_path = '$STORE_FREQ$_mean/$VAR_NAME$_3hourly/$VAR_NAME$_$START_DATE$.nc') +#'c <- ConfigAddEntry(c, 'observations', dataset_name = 'observation', +#' var_name = 'tos', main_path = obs_data_path, +#' file_path = '$STORE_FREQ$_mean/$VAR_NAME$/$VAR_NAME$_$YEAR$$MONTH$.nc') +#'ConfigFileSave(c, configfile, confirm = FALSE) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', c('experiment'), c('observation'), startDates, +#' output = 'areave', latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40, configfile = configfile) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' output = 'areave', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#'@import parallel bigmemory methods +#'@importFrom stats ts window na.omit +#'@export +Load <- function(var, exp = NULL, obs = NULL, sdates, nmember = NULL, + nmemberobs = NULL, nleadtime = NULL, leadtimemin = 1, + leadtimemax = NULL, storefreq = 'monthly', sampleperiod = 1, + lonmin = 0, lonmax = 360, latmin = -90, latmax = 90, + output = 'areave', method = 'conservative', grid = NULL, + maskmod = vector("list", 15), maskobs = vector("list", 15), + configfile = NULL, varmin = NULL, varmax = NULL, + silent = FALSE, nprocs = NULL, dimnames = NULL, + remapcells = 2, path_glob_permissive = 'partial') { + #library(parallel) + #library(bigmemory) + + # Print a stamp of the call the user issued. + parameter_names <- ls() + if (length(parameter_names) < 3 || is.null(var) || + is.null(sdates) || (is.null(exp) && is.null(obs))) { + stop("Error: At least 'var', 'exp'/'obs' and 'sdates' must be provided.") + } + load_parameters <- lapply(parameter_names, get, envir = environment()) + names(load_parameters) <- parameter_names + parameters_to_show <- c('var', 'exp', 'obs', 'sdates', 'nmember', 'leadtimemin', + 'leadtimemax', 'latmin', 'latmax', 'lonmin', 'lonmax', + 'output', 'grid', 'storefreq') + load_parameters <- c(load_parameters[parameters_to_show], load_parameters[-match(parameters_to_show, names(load_parameters))]) + if (!silent) { + message(paste("* The load call you issued is:\n* Load(", + paste(strwrap( + paste(unlist(lapply(names(load_parameters[1:length(parameters_to_show)]), + function(x) paste(x, '=', + if (x == 'sdates' && length(load_parameters[[x]]) > 4) { + paste0("c('", load_parameters[[x]][1], "', '", load_parameters[[x]][2], + "', ..., '", tail(load_parameters[[x]], 1), "')") + } else if ((x %in% c('exp', 'obs')) && is.list(load_parameters[[x]])) { + paste0("list(", paste(unlist(lapply(load_parameters[[x]], + function (y) { + paste0("list(", + if ('name' %in% names(y)) { + paste0('name = "', y[['name']], '", ...') + } else { + "..." + }, ")" + ) + })), collapse = ', '), + ")") + # Print a stamp of the call the user issued. + } else { + paste(deparse(load_parameters[[x]]), collapse = '') + }))), + collapse = ', '), width = getOption('width') - 9, indent = 0, exdent = 8), collapse = '\n*'), + ", ...)\n* See the full call in '$load_parameters' after Load() finishes.", sep = '')) + + } + + # Run Load() error-aware, so that it always returns something + errors <- try({ + + # Check and sanitize parameters + # var + if (is.null(var) || !(is.character(var) && nchar(var) > 0)) { + stop("Error: parameter 'var' should be a character string of length >= 1.") + } + + # exp + exps_to_fetch <- c() + exp_info_names <- c('name', 'path', 'nc_var_name', 'suffix', + 'var_min', 'var_max', 'dimnames') + if (!is.null(exp) && !(is.character(exp) && all(nchar(exp) > 0)) && !is.list(exp)) { + stop("Error: parameter 'exp' should be a vector of strings or a list with information of the experimental datasets to load. Check 'exp' in ?Load for details.") + } else if (!is.null(exp)) { + if (!is.list(exp)) { + exp <- lapply(exp, function (x) list(name = x)) + } + for (i in 1:length(exp)) { + if (!is.list(exp[[i]])) { + stop("Error: parameter 'exp' is incorrect. It should be a list of lists.") + } + #if (!(all(names(exp[[i]]) %in% exp_info_names))) { + # stop("Error: parameter 'exp' is incorrect. There are unrecognized components in the information of some of the experiments. Check 'exp' in ?Load for details.") + #} + if (!('name' %in% names(exp[[i]]))) { + exp[[i]][['name']] <- paste0('exp', i) + if (!('path' %in% names(exp[[i]]))) { + stop("Error: parameter 'exp' is incorrect. A 'path' should be provided for each experimental dataset if no 'name' is provided. See 'exp' in ?Load for details.") + } + } else if (!('path' %in% names(exp[[i]]))) { + exps_to_fetch <- c(exps_to_fetch, i) + } + if ('path' %in% names(exp[[i]])) { + if (!('nc_var_name' %in% names(exp[[i]]))) { + exp[[i]][['nc_var_name']] <- '$VAR_NAME$' + } + if (!('suffix' %in% names(exp[[i]]))) { + exp[[i]][['suffix']] <- '' + } + if (!('var_min' %in% names(exp[[i]]))) { + exp[[i]][['var_min']] <- '' + } + if (!('var_max' %in% names(exp[[i]]))) { + exp[[i]][['var_max']] <- '' + } + } + } + if ((length(exps_to_fetch) > 0) && (length(exps_to_fetch) < length(exp))) { + .warning("'path' was provided for some experimental datasets in 'exp'. Any information in the configuration file related to these will be ignored.") + } + } + + # obs + obs_to_fetch <- c() + obs_info_names <- c('name', 'path', 'nc_var_name', 'suffix', + 'var_min', 'var_max', 'dimnames') + if (!is.null(obs) && !(is.character(obs) && all(nchar(obs) > 0)) && !is.list(obs)) { + stop("Error: parameter 'obs' should be a vector of strings or a list with information of the observational datasets to load. Check 'obs' in ?Load for details.") + } else if (!is.null(obs)) { + if (!is.list(obs)) { + obs <- lapply(obs, function (x) list(name = x)) + } + for (i in 1:length(obs)) { + if (!is.list(obs[[i]])) { + stop("Error: parameter 'obs' is incorrect. It should be a list of lists.") + } + #if (!(all(names(obs[[i]]) %in% obs_info_names))) { + # stop("Error: parameter 'obs' is incorrect. There are unrecognized components in the information of some of the observations. Check 'obs' in ?Load for details.") + #} + if (!('name' %in% names(obs[[i]]))) { + obs[[i]][['name']] <- paste0('obs', i) + if (!('path' %in% names(obs[[i]]))) { + stop("Error: parameter 'obs' is incorrect. A 'path' should be provided for each observational dataset if no 'name' is provided. See 'obs' in ?Load for details.") + } + } else if (!('path' %in% names(obs[[i]]))) { + obs_to_fetch <- c(obs_to_fetch, i) + } + if ('path' %in% names(obs[[i]])) { + if (!('nc_var_name' %in% names(obs[[i]]))) { + obs[[i]][['nc_var_name']] <- '$VAR_NAME$' + } + if (!('suffix' %in% names(obs[[i]]))) { + obs[[i]][['suffix']] <- '' + } + if (!('var_min' %in% names(obs[[i]]))) { + obs[[i]][['var_min']] <- '' + } + if (!('var_max' %in% names(obs[[i]]))) { + obs[[i]][['var_max']] <- '' + } + } + } + if (length(c(obs_to_fetch, exps_to_fetch) > 1) && (length(obs_to_fetch) < length(obs))) { + .warning("'path' was provided for some observational datasets in 'obs'. Any information in the configuration file related to these will be ignored.") + } + } + + # sdates + if (is.null(sdates)) { + stop("Error: parameter 'sdates' must be provided.") + } + if (!is.character(sdates) || !all(nchar(sdates) == 8) || any(is.na(strtoi(sdates)))) { + stop("Error: parameter 'sdates' is incorrect. All starting dates should be a character string in the format 'YYYYMMDD'.") + } + + # nmember + if (!is.null(nmember) && !is.null(exp)) { + if (!is.numeric(nmember)) { + stop("Error: parameter 'nmember' is incorrect. It should be numeric.") + } + if (length(nmember) == 1) { + .warning(paste("'nmember' should specify the number of members of each experimental dataset. Forcing to", nmember, "for all experiments.")) + nmember <- rep(nmember, length(exp)) + } + if (length(nmember) != length(exp)) { + stop("Error: 'nmember' must contain as many values as 'exp'.") + } else if (any(is.na(nmember))) { + nmember[which(is.na(nmember))] <- max(nmember, na.rm = TRUE) + } + } + + # nmemberobs + if (!is.null(nmemberobs) && !is.null(obs)) { + if (!is.numeric(nmemberobs)) { + stop("Error: parameter 'nmemberobs' is incorrect. It should be numeric.") + } + if (length(nmemberobs) == 1) { + .warning(paste("'nmemberobs' should specify the number of members of each observational dataset. Forcing to", nmemberobs, "for all observations.")) + nmemberobs <- rep(nmemberobs, length(obs)) + } + if (length(nmemberobs) != length(obs)) { + stop("Error: 'nmemberobs' must contain as many values as 'obs'.") + } else if (any(is.na(nmemberobs))) { + nmemberobs[which(is.na(nmemberobs))] <- max(nmemberobs, na.rm = TRUE) + } + } + + # nleadtime + if (!is.null(nleadtime) && !is.numeric(nleadtime)) { + stop("Error: parameter 'nleadtime' is wrong. It should be numeric.") + } + + # leadtimemin + if (is.null(leadtimemin) || !is.numeric(leadtimemin)) { + stop("Error: parameter 'leadtimemin' is wrong. It should be numeric.") + } + + # leadtimemax + if (!is.null(leadtimemax) && !is.numeric(leadtimemax)) { + stop("Error: parameter 'leadtimemax' is wrong. It should be numeric.") + } + + # storefreq + if (!is.character(storefreq) || !(storefreq %in% c('monthly', 'daily'))) { + stop("Error: parameter 'storefreq' is wrong, can take value 'daily' or 'monthly'.") + } + + # sampleperiod + if (is.null(sampleperiod) || !is.numeric(sampleperiod)) { + stop("Error: parameter 'sampleperiod' is wrong. It should be numeric.") + } + + # lonmin + if (is.null(lonmin) || !is.numeric(lonmin)) { + stop("Error: parameter 'lonmin' is wrong. It should be numeric.") + } + if (lonmin < -360 || lonmin > 360) { + stop("Error: parameter 'lonmin' must be in the range [-360, 360]") + } + if (lonmin < 0) { + lonmin <- lonmin + 360 + } + + # lonmax + if (is.null(lonmax) || !is.numeric(lonmax)) { + stop("Error: parameter 'lonmax' is wrong. It should be numeric.") + } + if (lonmax < -360 || lonmax > 360) { + stop("Error: parameter 'lonmax' must be in the range [-360, 360]") + } + if (lonmax < 0) { + lonmax <- lonmax + 360 + } + + # latmin + if (is.null(latmin) || !is.numeric(latmin)) { + stop("Error: parameter 'latmin' is wrong. It should be numeric.") + } + if (latmin > 90 || latmin < -90) { + stop("Error: 'latmin' must be in the interval [-90, 90].") + } + + # latmax + if (is.null(latmax) || !is.numeric(latmax)) { + stop("Error: parameter 'latmax' is wrong. It should be numeric.") + } + if (latmax > 90 || latmax < -90) { + stop("Error: 'latmax' must be in the interval [-90, 90].") + } + + # output + if (is.null(output) || !(output %in% c('lonlat', 'lon', 'lat', 'areave'))) { + stop("Error: 'output' can only take values 'lonlat', 'lon', 'lat' or 'areave'.") + } + + # method + if (is.null(method) || !(method %in% c('bilinear', 'bicubic', 'conservative', 'distance-weighted'))) { + stop("Error: parameter 'method' is wrong, can take value 'bilinear', 'bicubic', 'conservative' or 'distance-weighted'.") + } + remap <- switch(method, 'bilinear' = 'bil', 'bicubic' = 'bic', + 'conservative' = 'con', 'distance-weighted' = 'dis') + + # grid + if (!is.null(grid)) { + if (is.character(grid)) { + if (grid == 'none') { + grid <- NULL + } else { + supported_grids <- list('r[0-9]{1,}x[0-9]{1,}', 't[0-9]{1,}grid') + grid_matches <- unlist(lapply(lapply(supported_grids, regexpr, grid), .IsFullMatch, grid)) + if (sum(grid_matches) < 1) { + stop("The specified grid in the parameter 'grid' is incorrect. Must be one of rx or tgrid.") + } + } + } else { + stop("Error: parameter 'grid' should be a character string, if specified.") + } + } + + # maskmod + if (!is.list(maskmod)) { + stop("Error: parameter 'maskmod' must be a list.") + } + if (length(maskmod) < length(exp)) { + stop("Error: 'maskmod' must contain a numeric mask or NULL for each experiment in 'exp'.") + } + for (i in 1:length(maskmod)) { + if (is.list(maskmod[[i]])) { + if ((length(maskmod[[i]]) > 2) || !all(names(maskmod[[i]]) %in% c('path', 'nc_var_name'))) { + stop("Error: all masks in 'maskmod' must be a numeric matrix, or a list with the components 'path' and optionally 'nc_var_name', or NULL.") + } + } else if (!(is.numeric(maskmod[[i]]) || is.null(maskmod[[i]]))) { + stop("Error: all masks in 'maskmod' must be a numeric matrix, or a list with the components 'path' and optionally 'nc_var_name', or NULL.") + } + } + + # maskobs + if (!is.list(maskobs)) { + stop("Error: parameter 'maskobs' must be a list.") + } + if (length(maskobs) < length(obs)) { + stop("Error: 'maskobs' must contain a numeric mask or NULL for each obseriment in 'obs'.") + } + for (i in 1:length(maskobs)) { + if (is.list(maskobs[[i]])) { + if ((length(maskobs[[i]]) > 2) || !all(names(maskobs[[i]]) %in% c('path', 'nc_var_name'))) { + stop("Error: all masks in 'maskobs' must be a numeric matrix, or a list with the components 'path' and optionally 'nc_var_name', or NULL.") + } + } else if (!(is.numeric(maskobs[[i]]) || is.null(maskobs[[i]]))) { + stop("Error: all masks in 'maskobs' must be a numeric matrix, or a list with the components 'path' and optionally 'nc_var_name', or NULL.") + } + } + + ## Force the observational masks to be the same as the experimental when + ## possible. + if ((output != 'areave' || !is.null(grid)) && length(exp) > 0) { + if (!all(unlist(lapply(maskobs, is.null)))) { + .warning("'maskobs' will be ignored. 'maskmod[[1]]' will be applied to observations instead.") + } + maskobs <- lapply(maskobs, function(x) x <- maskmod[[1]]) + } + + # configfile + if (is.null(configfile)) { + configfile <- system.file("config", "BSC.conf", package = "s2dverification") + } else if (!is.character(configfile) || !(nchar(configfile) > 0)) { + stop("Error: parameter 'configfile' must be a character string with the path to an s2dverification configuration file, if specified.") + } + + # varmin + if (!is.null(varmin) && !is.numeric(varmin)) { + stop("Error: parameter 'varmin' must be numeric, if specified.") + } + + # varmax + if (!is.null(varmax) && !is.numeric(varmax)) { + stop("Error: parameter 'varmax' must be numeric, if specified.") + } + + # silent + if (!is.logical(silent)) { + stop("Error: parameter 'silent' must be TRUE or FALSE.") + } + + # nprocs + if (!is.null(nprocs) && (!is.numeric(nprocs) || nprocs < 1)) { + stop("Error: parameter 'nprocs' must be a positive integer, if specified.") + } + + # dimnames + if (!is.null(dimnames) && (!is.list(dimnames))) { + stop("Error: parameter 'dimnames' must be a list, if specified.") + } + if (!all(names(dimnames) %in% c('member', 'lat', 'lon'))) { + stop("Error: parameter 'dimnames' is wrong. There are unrecognized component names. See 'dimnames' in ?Load for details.") + } + + # remapcells + if (!is.numeric(remapcells) || remapcells < 0) { + stop("Error: 'remapcells' must be an integer >= 0.") + } + + # path_glob_permissive + if (!is.logical(path_glob_permissive) && !(path_glob_permissive %in% c('yes', 'partial', 'no'))) { + stop("Error: 'path_glob_permissive' must be one of TRUE, 'yes', 'partial', FALSE or 'no'.") + } + if (is.logical(path_glob_permissive)) { + if (path_glob_permissive) { + path_glob_permissive <- 'yes' + } else { + path_glob_permissive <- 'no' + } + } + replace_globs <- path_glob_permissive %in% c('no', 'partial') + + # If not all data has been provided in 'exp' and 'obs', configuration file is read. + if ((length(exps_to_fetch) > 0 || length(obs_to_fetch) > 0)) { + if (!silent) { + .message("Some 'path's not explicitly provided in 'exp' and 'obs', so will now proceed to open the configuration file.") + } + data_info <- ConfigFileOpen(configfile, silent, TRUE) + + # Check that the var, exp and obs parameters are right and keep the entries + # that match for each dataset. + # Afterwards, the matching entries are applied sequentially (as specified + # in ?ConfigFileOpen) and the replace_values are applied to the result. + # Finally a path pattern for each dataset is provided. + matches <- ConfigApplyMatchingEntries(data_info, var, sapply(exp[exps_to_fetch], '[[', 'name'), + sapply(obs[obs_to_fetch], '[[', 'name'), show_entries = FALSE, show_result = FALSE) + # 'replace_values' is a named list that associates a variable name to an + # associated value. Initially it is filled with variables and values parsed + # from the configuration file, but we can add or modify some values during + # the execution to choose for example which start date we want to load. + # When '.ConfigReplaceVariablesInString' is called, all the variable accesses + # ($VARIABLE_NAME$) that appear in the string given as parameter are + # replaced by the associated value in 'replace_values'. + replace_values <- data_info$definitions + if (!is.null(exp) && length(exps_to_fetch) > 0) { + counter <- 1 + exp[exps_to_fetch] <- lapply(matches$exp_info, + function (x) { + x[names(exp[[exps_to_fetch[counter]]])] <- exp[[exps_to_fetch[counter]]] + x[['path']] <- paste0(x[['main_path']], x[['file_path']]) + counter <<- counter + 1 + x + }) + } + if (!is.null(obs) && length(obs_to_fetch) > 0) { + counter <- 1 + obs[obs_to_fetch] <- lapply(matches$obs_info, + function (x) { + x[names(obs[[obs_to_fetch[counter]]])] <- obs[[obs_to_fetch[counter]]] + x[['path']] <- paste0(x[['main_path']], x[['file_path']]) + counter <<- counter + 1 + x + }) + } + if (!silent) { + .message("All pairs (var, exp) and (var, obs) have matching entries.") + } + } else { + replace_values <- list(DEFAULT_NC_VAR_NAME = '$VAR_NAME$', + DEFAULT_VAR_MIN = '', + DEFAULT_VAR_MAX = '', + DEFAULT_SUFFIX = '', + DEFAULT_DIM_NAME_LONGITUDES = 'longitude', + DEFAULT_DIM_NAME_LATITUDES = 'latitude', + DEFAULT_DIM_NAME_MEMBERS = 'ensemble') + } + # We take the dimnames that haven't been explicitly specified from the + # configuration file. + # If the configuration file wasn't opened, we take the default values from + # the dictionary 'replace_values'. + dimnames <- list(lon = ifelse(is.null(dimnames[["lon"]]), + replace_values[["DEFAULT_DIM_NAME_LONGITUDES"]], + dimnames[['lon']]), + lat = ifelse(is.null(dimnames[["lat"]]), + replace_values[["DEFAULT_DIM_NAME_LATITUDES"]], + dimnames[['lat']]), + member = ifelse(is.null(dimnames[["member"]]), + replace_values[["DEFAULT_DIM_NAME_MEMBERS"]], + dimnames[['member']])) + mandatory_defaults <- c('DEFAULT_EXP_MAIN_PATH', 'DEFAULT_EXP_FILE_PATH', + 'DEFAULT_OBS_MAIN_PATH', 'DEFAULT_OBS_FILE_PATH', + 'DEFAULT_NC_VAR_NAME', 'DEFAULT_SUFFIX', + 'DEFAULT_VAR_MIN', 'DEFAULT_VAR_MAX', + 'DEFAULT_DIM_NAME_LONGITUDES', + 'DEFAULT_DIM_NAME_LATITUDES', + 'DEFAULT_DIM_NAME_MEMBERS') + extra_vars_with_default_ind <- (1:length(replace_values))[grep('^DEFAULT_', names(replace_values))] + extra_vars_with_default_ind <- extra_vars_with_default_ind[ + grep(paste0(paste0('^', mandatory_defaults), + collapse = '|'), + names(replace_values)[extra_vars_with_default_ind], + invert = TRUE) + ] + extra_vars_with_default <- gsub('^DEFAULT_', '', + names(replace_values)[extra_vars_with_default_ind]) + if (!is.null(exp)) { + exp <- lapply(exp, function (x) { + if (!('dimnames' %in% names(x))) { + x[['dimnames']] <- dimnames + } else { + dimnames2 <- dimnames + dimnames2[names(x[['dimnames']])] <- x[['dimnames']] + x[['dimnames']] <- dimnames2 + } + i <- 1 + while (i <= length(extra_vars_with_default)) { + if (!(extra_vars_with_default[i] %in% names(x))) { + x[[extra_vars_with_default[i]]] <- replace_values[[extra_vars_with_default_ind[i]]] + } + i <- i + 1 + } + x + }) + } + if (!is.null(obs)) { + obs <- lapply(obs, function (x) { + if (!('dimnames' %in% names(x))) { + x[['dimnames']] <- dimnames + } else { + dimnames2 <- dimnames + dimnames2[names(x[['dimnames']])] <- x[['dimnames']] + x[['dimnames']] <- dimnames2 + } + i <- 1 + while (i <= length(extra_vars_with_default)) { + if (!(extra_vars_with_default[i] %in% names(x))) { + x[[extra_vars_with_default[i]]] <- replace_values[[extra_vars_with_default_ind[i]]] + } + i <- i + 1 + } + x + }) + } + single_dataset <- (length(obs) + length(exp) == 1) + + ## We add some predefined values in the dictionary. + replace_values[["VAR_NAME"]] <- var + replace_values[["STORE_FREQ"]] <- storefreq + + # Initialize some variables that will take various values along the + # execution + latitudes <- longitudes <- NULL + leadtimes <- NULL + var_exp <- var_obs <- NULL + units <- var_long_name <- NULL + is_2d_var <- data_across_gw <- array_across_gw <- FALSE + + # Start defining the dimensions of the output matrices + nmod <- length(exp) + nobs <- length(obs) + nsdates <- length(sdates) + + # We will iterate over all the experiments, start dates and members and will open + # the file pointed by the data in the configuration file. + # If a file is found, we will open it and read its metadata to work out the + # remaining dimensions: members, leadtimes, longitudes and latitudes. + # + # At each iteration we will build a 'work piece' that will contain information + # on the data we want to load from a file. For each file we will have one + # work piece. These work pieces will be packages of information to be sent to + # the various parallel processes. Each process will need this information to + # access and manipulate the data according to the output type and other + # parameters. + if (!silent) { + .message("Fetching first experimental files to work out 'var_exp' size...") + } + + dataset_type <- 'exp' + dim_exp <- NULL + filename <- file_found <- tmp <- nltime <- NULL + dims2define <- TRUE + is_file_per_member_exp <- rep(nmod, FALSE) + exp_work_pieces <- list() + jmod <- 1 + while (jmod <= nmod) { + first_dataset_file_found <- FALSE + replace_values[["EXP_NAME"]] <- exp[[jmod]][['name']] + replace_values[["NC_VAR_NAME"]] <- exp[[jmod]][['nc_var_name']] + replace_values[["SUFFIX"]] <- exp[[jmod]][['suffix']] + extra_vars <- names(exp[[jmod]])[which(!(names(exp[[jmod]]) %in% exp_info_names))] + replace_values[extra_vars] <- exp[[jmod]][extra_vars] + namevar <- .ConfigReplaceVariablesInString(exp[[jmod]][['nc_var_name']], replace_values) + tags_to_find <- c('START_DATE', 'YEAR', 'MONTH', 'DAY', 'MEMBER_NUMBER') + position_of_tags <- na.omit(match(tags_to_find, names(replace_values))) + if (length(position_of_tags) > 0) { + quasi_final_path <- .ConfigReplaceVariablesInString(exp[[jmod]][['path']], + replace_values[-position_of_tags], TRUE) + } else { + quasi_final_path <- .ConfigReplaceVariablesInString(exp[[jmod]][['path']], + replace_values, TRUE) + } + if (!grepl('$START_DATE$', quasi_final_path, fixed = TRUE) && + !all(sapply(c('$YEAR$', '$MONTH$'), grepl, quasi_final_path, + fixed = TRUE))) { + stop(paste0("The tag $START_DATE$ or the three tags $YEAR$, $MONTH$, $DAY$ must be somewhere in the path pattern of the experimental dataset '", + exp[[jmod]][['name']], "'.")) + } + is_file_per_member_exp[jmod] <- grepl('$MEMBER_NUMBER$', + quasi_final_path, fixed = TRUE) + if (is.null(varmin)) { + mod_var_min <- as.numeric(.ConfigReplaceVariablesInString(exp[[jmod]][['var_min']], replace_values)) + } else { + mod_var_min <- varmin + } + if (is.null(varmax)) { + mod_var_max <- as.numeric(.ConfigReplaceVariablesInString(exp[[jmod]][['var_max']], replace_values)) + } else { + mod_var_max <- varmax + } + jsdate <- 1 + while (jsdate <= nsdates) { + replace_values[["START_DATE"]] <- sdates[jsdate] + replace_values[["YEAR"]] <- substr(sdates[jsdate], 1, 4) + replace_values[["MONTH"]] <- substr(sdates[jsdate], 5, 6) + replace_values[["DAY"]] <- substr(sdates[jsdate], 7, 8) + if (is_file_per_member_exp[jmod]) { + replace_values[["MEMBER_NUMBER"]] <- '*' + } + # If the dimensions of the output matrices are still to define, we try to read + # the metadata of the data file that corresponds to the current iteration + if (dims2define) { + # We must build a work piece that will be sent to the .LoadDataFile function + # in 'explore_dims' mode. We will obtain, if success, the dimensions of the + # data in the file. + work_piece <- list(dataset_type = dataset_type, + filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, grid = grid, remap = remap, remapcells = remapcells, + is_file_per_member = is_file_per_member_exp[jmod], + is_file_per_dataset = FALSE, + lon_limits = c(lonmin, lonmax), + lat_limits = c(latmin, latmax), dimnames = exp[[jmod]][['dimnames']], + single_dataset = single_dataset) + found_data <- .LoadDataFile(work_piece, explore_dims = TRUE, silent = silent) + found_dims <- found_data$dims + var_long_name <- found_data$var_long_name + units <- found_data$units + if (!is.null(found_dims)) { + # If a file is found, we can define the dimensions of the output arrays. + is_2d_var <- found_data$is_2d_var + if (!is_2d_var && (output != 'areave')) { + .warning(paste0("'", output, "' output format not allowed when loading global mean variables. Forcing to 'areave'.")) + output <- 'areave' + } + if (output == 'lonlat' || output == 'lon') { + data_across_gw <- found_data$data_across_gw + array_across_gw <- found_data$array_across_gw + } + if (output != 'areave' && is.null(grid)) { + grid <- found_data$grid + } + if (is.null(nmember)) { + if (is.null(found_dims[['member']])) { + .warning("loading data from a server but 'nmember' not specified. Loading only one member.") + nmember <- rep(1, nmod) + } else { + nmember <- rep(found_dims[['member']], nmod) + } + } + if (is.null(nleadtime)) { + nleadtime <- found_dims[['ftime']] + } + if (is.null(leadtimemax)) { + leadtimemax <- nleadtime + } else if (leadtimemax > nleadtime) { + stop("Error: 'leadtimemax' argument is greater than the number of loaded leadtimes. Put first the experiment with the greatest number of leadtimes or adjust properly the parameters 'nleadtime' and 'leadtimemax'.") + } + leadtimes <- seq(leadtimemin, leadtimemax, sampleperiod) + latitudes <- found_dims[['lat']] + longitudes <- found_dims[['lon']] + + if (output == 'lon' || output == 'lonlat') { + dim_exp[['lon']] <- length(longitudes) + } + if (output == 'lat' || output == 'lonlat') { + dim_exp[['lat']] <- length(latitudes) + } + dim_exp[['ftime']] <- length(leadtimes) + dim_exp[['member']] <- max(nmember) + dim_exp[['sdate']] <- nsdates + dim_exp[['dataset']] <- nmod + dims2define <- FALSE + } + } + # Also, we must get rid of the shell globbing expressions in the + # quasi_final_path, for safety. + if (!first_dataset_file_found) { + found_path <- Sys.glob(.ConfigReplaceVariablesInString(quasi_final_path, replace_values)) + if (length(found_path) > 0) { + found_path <- head(found_path, 1) + if (replace_globs) { + quasi_final_path <- .ReplaceGlobExpressions(quasi_final_path, found_path, + replace_values, tags_to_find, + exp[[jmod]][['name']], + path_glob_permissive == 'partial') + } + first_dataset_file_found <- TRUE + } + } + # We keep on iterating through members to build all the work pieces. + if (is_file_per_member_exp[jmod]) { + jmember <- 1 + while (jmember <= nmember[jmod]) { + replace_values[["MEMBER_NUMBER"]] <- sprintf(paste("%.", (nmember[jmod] %/% 10) + 1, "i", sep = ''), jmember - 1) + work_piece <- list(filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, indices = c(1, jmember, jsdate, jmod), + nmember = nmember[jmod], leadtimes = leadtimes, mask = maskmod[[jmod]], + is_file_per_dataset = FALSE, dimnames = exp[[jmod]][['dimnames']], + var_limits = c(mod_var_min, mod_var_max), remapcells = remapcells) + exp_work_pieces <- c(exp_work_pieces, list(work_piece)) + jmember <- jmember + 1 + } + } else { + work_piece <- list(filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, indices = c(1, 1, jsdate, jmod), + nmember = nmember[jmod], leadtimes = leadtimes, mask = maskmod[[jmod]], + is_file_per_dataset = FALSE, dimnames = exp[[jmod]][['dimnames']], + var_limits = c(mod_var_min, mod_var_max), remapcells = remapcells) + exp_work_pieces <- c(exp_work_pieces, list(work_piece)) + } + jsdate <- jsdate + 1 + } + replace_values[extra_vars] <- NULL + jmod <- jmod + 1 + } + if (dims2define && length(exp) > 0) { + .warning("no data found in file system for any experimental dataset.") + } + + dims <- dim_exp[na.omit(match(c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon'), names(dim_exp)))] + if (is.null(dims[['member']]) || any(is.na(unlist(dims))) || any(unlist(dims) == 0)) { + dims <- 0 + dim_exp <- NULL + } + if (!silent) { + message <- "Success. Detected dimensions of experimental data: " + .message(paste0(message, paste(unlist(dims), collapse = ', '))) + .message("Fetching first observational files to work out 'var_obs' size...") + } + + # If there are no experiments to load we need to choose a number of time steps + # to load from observational datasets. We load from the first start date to + # the current date. + if (is.null(exp) || dims == 0) { + if (is.null(leadtimemax)) { + diff <- Sys.time() - as.POSIXct(sdates[1], format = '%Y%m%d') + if (diff > 0) { + .warning("Loading observations only and no 'leadtimemax' specified. Data will be loaded from each starting date to current time.") + if (storefreq == 'monthly') { + leadtimemax <- as.integer(diff / 30) + if (leadtimemax == 0) leadtimemax <- 1 + } else { + leadtimemax <- as.integer(diff) + } + } else { + stop("Loading only observational data for future start dates but no 'leadtimemax' specified.") + } + } + if (is.null(nleadtime)) { + nleadtime <- leadtimemax + } + leadtimes <- seq(leadtimemin, leadtimemax, sampleperiod) + } + + # Now we start iterating over observations. We try to find the output matrix + # dimensions and we build anyway the work pieces corresponding to the observational + # data that time-corresponds the experimental data or the time-steps until the + # current date if no experimental datasets were specified. + dataset_type <- 'obs' + dim_obs <- NULL + dims2define <- TRUE + lat_indices <- lon_indices <- NULL + obs_work_pieces <- list() + is_file_per_dataset_obs <- rep(FALSE, nobs) + is_file_per_member_obs <- rep(FALSE, nobs) + jobs <- 1 + while (jobs <= nobs) { + first_dataset_file_found <- FALSE + replace_values[["OBS_NAME"]] <- obs[[jobs]][['name']] + replace_values[["NC_VAR_NAME"]] <- obs[[jobs]][['nc_var_name']] + replace_values[["SUFFIX"]] <- obs[[jobs]][['suffix']] + extra_vars <- names(obs[[jobs]])[which(!(names(obs[[jobs]]) %in% obs_info_names))] + replace_values[extra_vars] <- obs[[jobs]][extra_vars] + namevar <- .ConfigReplaceVariablesInString(obs[[jobs]][['nc_var_name']], replace_values) + tags_to_find <- c('START_DATE', 'MONTH', 'DAY', 'YEAR', 'MEMBER_NUMBER') + position_of_tags <- na.omit(match(tags_to_find, names(replace_values))) + if (length(position_of_tags) > 0) { + quasi_final_path <- .ConfigReplaceVariablesInString(obs[[jobs]][['path']], + replace_values[-position_of_tags], TRUE) + } else { + quasi_final_path <- .ConfigReplaceVariablesInString(obs[[jobs]][['path']], + replace_values, TRUE) + } + is_file_per_dataset_obs[jobs] <- !any(sapply(c("$MONTH$", "$DAY$", "$YEAR$"), + grepl, quasi_final_path, fixed = TRUE)) + is_file_per_member_obs[jobs] <- grepl("$MEMBER_NUMBER$", quasi_final_path, fixed = TRUE) + if (is.null(varmin)) { + obs_var_min <- as.numeric(.ConfigReplaceVariablesInString(obs[[jobs]][['var_min']], replace_values)) + } else { + obs_var_min <- varmin + } + if (is.null(varmax)) { + obs_var_max <- as.numeric(.ConfigReplaceVariablesInString(obs[[jobs]][['var_max']], replace_values)) + } else { + obs_var_max <- varmax + } + # This file format (file per whole dataset) is only supported in observations. + # However a file per whole dataset experiment could be seen as a file per + # member/ensemble experiment with a single start date, so still loadable. + # Nonetheless file per whole dataset observational files do not need to contain + # a year and month in the filename, the time correspondance relies on the + # month and years associated to each timestep inside the NetCDF file. + # So file per whole dataset experiments need to have a start date in the filename. + if (is_file_per_dataset_obs[jobs]) { + ## TODO: Open file-per-dataset-files only once. + if (dims2define) { + work_piece <- list(dataset_type = dataset_type, + filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, grid = grid, remap = remap, remapcells = remapcells, + is_file_per_member = is_file_per_member_obs[jobs], + is_file_per_dataset = is_file_per_dataset_obs[jobs], + lon_limits = c(lonmin, lonmax), + lat_limits = c(latmin, latmax), dimnames = obs[[jobs]][['dimnames']], + single_dataset = single_dataset) + found_data <- .LoadDataFile(work_piece, explore_dims = TRUE, silent = silent) + found_dims <- found_data$dims + var_long_name <- found_data$var_long_name + units <- found_data$units + if (!is.null(found_dims)) { + is_2d_var <- found_data$is_2d_var + if (!is_2d_var && (output != 'areave')) { + .warning(paste0("'", output, "' output format not allowed when loading global mean variables. Forcing to 'areave'.")) + output <- 'areave' + } + if (output == 'lonlat' || output == 'lon') { + data_across_gw <- found_data$data_across_gw + array_across_gw <- found_data$array_across_gw + } + if (output != 'areave' && is.null(grid)) { + grid <- found_data$grid + } + if (is.null(nmemberobs)) { + if (is.null(found_dims[['member']])) { + .warning("loading observational data from a server but 'nmemberobs' not specified. Loading only one member.") + nmemberobs <- rep(1, nobs) + } else { + nmemberobs <- rep(found_dims[['member']], nobs) + } + } + if (is.null(dim_exp)) { + longitudes <- found_dims[['lon']] + latitudes <- found_dims[['lat']] + } + + if (output == 'lon' || output == 'lonlat') { + dim_obs[['lon']] <- length(longitudes) + } + if (output == 'lat' || output == 'lonlat') { + dim_obs[['lat']] <- length(latitudes) + } + dim_obs[['ftime']] <- length(leadtimes) + dim_obs[['member']] <- max(nmemberobs) + dim_obs[['sdate']] <- nsdates + dim_obs[['dataset']] <- nobs + dims2define <- FALSE + } + } + if (!first_dataset_file_found) { + found_path <- Sys.glob(.ConfigReplaceVariablesInString(quasi_final_path, replace_values)) + if (length(found_path) > 0) { + found_path <- head(found_path, 1) + if (replace_globs) { + quasi_final_path <- .ReplaceGlobExpressions(quasi_final_path, found_path, + replace_values, tags_to_find, + obs[[jobs]][['name']], + path_glob_permissive == 'partial') + } + first_dataset_file_found <- TRUE + } + } + work_piece <- list(filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, indices = c(1, 1, 1, jobs), + nmember = nmemberobs[jobs], + mask = maskobs[[jobs]], leadtimes = leadtimes, + is_file_per_dataset = is_file_per_dataset_obs[jobs], + startdates = sdates, dimnames = obs[[jobs]][['dimnames']], + var_limits = c(obs_var_min, obs_var_max), remapcells = remapcells) + obs_work_pieces <- c(obs_work_pieces, list(work_piece)) + } else { + jsdate <- 1 + while (jsdate <= nsdates) { + replace_values[["START_DATE"]] <- sdates[jsdate] + sdate <- sdates[jsdate] + + if (storefreq == 'daily') { + day <- substr(sdate, 7, 8) + if (day == '') { + day <- '01' + } + day <- as.integer(day) + startdate <- as.POSIXct(paste(substr(sdate, 1, 4), '-', + substr(sdate, 5, 6), '-', day, ' 12:00:00', sep = '')) + + (leadtimemin - 1) * 86400 + year <- as.integer(substr(startdate, 1, 4)) + month <- as.integer(substr(startdate, 6, 7)) + } else { + month <- (as.integer(substr(sdate, 5, 6)) + leadtimemin - 2) %% 12 + 1 + year <- as.integer(substr(sdate, 1, 4)) + (as.integer(substr(sdate, + 5, 6)) + leadtimemin - 2) %/% 12 + } + jleadtime <- 1 + while (jleadtime <= length(leadtimes)) { + replace_values[["YEAR"]] <- paste(year, '', sep = '') + replace_values[["MONTH"]] <- sprintf("%2.2i", month) + if (storefreq == 'daily') { + replace_values[["DAY"]] <- sprintf("%2.2i", day) + days_in_month <- ifelse(LeapYear(year), 29, 28) + days_in_month <- switch(paste(month, '', sep = ''), '1' = 31, + '3' = 31, '4' = 30, '5' = 31, '6' = 30, + '7' = 31, '8' = 31, '9' = 30, '10' = 31, + '11' = 30, '12' = 31, days_in_month) + ## This condition must be fulfilled to put all the month time steps + ## in the dimension of length nleadtimes. Otherwise it must be cut: + #(length(leadtimes) - 1)*sampleperiod + 1 - (jleadtime - 1)*sampleperiod >= days_in_month - day + 1 + obs_file_indices <- seq(day, min(days_in_month, (length(leadtimes) - jleadtime) * sampleperiod + day), sampleperiod) + } else { + obs_file_indices <- 1 + } + if (is_file_per_member_obs[jobs]) { + replace_values[["MEMBER_NUMBER"]] <- '*' + } + if (dims2define) { + work_piece <- list(dataset_type = dataset_type, + filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, grid = grid, remap = remap, remapcells = remapcells, + is_file_per_member = is_file_per_member_obs[jobs], + is_file_per_dataset = is_file_per_dataset_obs[jobs], + lon_limits = c(lonmin, lonmax), + lat_limits = c(latmin, latmax), + dimnames = obs[[jobs]][['dimnames']], single_dataset = single_dataset) + found_data <- .LoadDataFile(work_piece, explore_dims = TRUE, silent = silent) + found_dims <- found_data$dims + var_long_name <- found_data$var_long_name + units <- found_data$units + if (!is.null(found_dims)) { + is_2d_var <- found_data$is_2d_var + if (!is_2d_var && (output != 'areave')) { + .warning(paste0("'", output, "' output format not allowed when loading global mean variables. Forcing to 'areave'.")) + output <- 'areave' + } + if (output == 'lonlat' || output == 'lon') { + data_across_gw <- found_data$data_across_gw + array_across_gw <- found_data$array_across_gw + } + if (output != 'areave' && is.null(grid)) { + grid <- found_data$grid + } + if (is.null(nmemberobs)) { + if (is.null(found_dims[['member']])) { + .warning("loading observational data from a server but 'nmemberobs' not specified. Loading only one member.") + nmemberobs <- rep(1, nobs) + } else { + nmemberobs <- rep(found_dims[['member']], nobs) + } + } + if (is.null(dim_exp)) { + longitudes <- found_dims[['lon']] + latitudes <- found_dims[['lat']] + } + + if (output == 'lon' || output == 'lonlat') { + dim_obs[['lon']] <- length(longitudes) + } + if (output == 'lat' || output == 'lonlat') { + dim_obs[['lat']] <- length(latitudes) + } + dim_obs[['ftime']] <- length(leadtimes) + dim_obs[['member']] <- max(nmemberobs) + dim_obs[['sdate']] <- nsdates + dim_obs[['dataset']] <- nobs + dims2define <- FALSE + } + } + if (!first_dataset_file_found) { + found_path <- Sys.glob(.ConfigReplaceVariablesInString(quasi_final_path, replace_values)) + if (length(found_path) > 0) { + found_path <- head(found_path, 1) + if (replace_globs) { + quasi_final_path <- .ReplaceGlobExpressions(quasi_final_path, found_path, + replace_values, tags_to_find, + obs[[jobs]][['name']], + path_glob_permissive == 'partial') + } + first_dataset_file_found <- TRUE + } + } + if (is_file_per_member_obs[jobs]) { + jmember <- 1 + while (jmember <= nmemberobs[jobs]) { + replace_values[["MEMBER_NUMBER"]] <- sprintf(paste("%.", (nmemberobs[jobs] %/% 10) + 1, "i", sep = ''), jmember - 1) + work_piece <- list(filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, indices = c(jleadtime, jmember, jsdate, jobs), + nmember = nmemberobs[jobs], leadtimes = obs_file_indices, + mask = maskobs[[jobs]], dimnames = obs[[jobs]][['dimnames']], + is_file_per_dataset = is_file_per_dataset_obs[jobs], + var_limits = c(obs_var_min, obs_var_max), remapcells = remapcells) + obs_work_pieces <- c(obs_work_pieces, list(work_piece)) + jmember <- jmember + 1 + } + } else { + work_piece <- list(filename = .ConfigReplaceVariablesInString(quasi_final_path, replace_values), + namevar = namevar, indices = c(jleadtime, 1, jsdate, jobs), + nmember = nmemberobs[jobs], leadtimes = obs_file_indices, + mask = maskobs[[jobs]], dimnames = obs[[jobs]][['dimnames']], + is_file_per_dataset = is_file_per_dataset_obs[jobs], + var_limits = c(obs_var_min, obs_var_max), remapcells) + obs_work_pieces <- c(obs_work_pieces, list(work_piece)) + } + + if (storefreq == 'daily') { + startdate <- startdate + 86400 * sampleperiod * length(obs_file_indices) + year <- as.integer(substr(startdate, 1, 4)) + month <- as.integer(substr(startdate, 6, 7)) + day <- as.integer(substr(startdate, 9, 10)) + } else { + month <- month + sampleperiod + year <- year + (month - 1) %/% 12 + month <- (month - 1) %% 12 + 1 + } + jleadtime <- jleadtime + length(obs_file_indices) + } + + jsdate <- jsdate + 1 + } + } + replace_values[extra_vars] <- NULL + jobs <- jobs + 1 + } + if (dims2define && length(obs) > 0) { + .warning("no data found in file system for any observational dataset.") + } + dims <- dim_obs[na.omit(match(c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon'), names(dim_obs)))] + if (is.null(dims[['member']]) || any(is.na(unlist(dims))) || any(unlist(dims) == 0)) { + dims <- 0 + dim_obs <- NULL + } + if (!silent) { + message <- "Success. Detected dimensions of observational data: " + .message(paste0(message, paste(unlist(dims), collapse = ', '))) + } + + if (!(is.null(dim_obs) && is.null(dim_exp))) { + + # We build two matrices in shared memory for the parallel processes to + # store their results + # These matrices will contain data arranged with the following + # dimension order, to maintain data spacial locality during the + # parallel fetch: + # longitudes, latitudes, leadtimes, members, startdates, nmod/nobs + # So [1, 1, 1, 1, 1, 1] will be next to [2, 1, 1, 1, 1, 1] in memory + pointer_var_exp <- pointer_var_obs <- NULL + if (!is.null(dim_exp) && (length(unlist(dim_exp)) == length(dim_exp)) && + !any(is.na(unlist(dim_exp))) && !any(unlist(dim_exp) == 0)) { + var_exp <- big.matrix(nrow = prod(unlist(dim_exp)), ncol = 1) + pointer_var_exp <- describe(var_exp) + } + if (!is.null(dim_obs) && (length(unlist(dim_obs)) == length(dim_obs)) && + !any(is.na(unlist(dim_obs))) && !any(unlist(dim_obs) == 0)) { + var_obs <- big.matrix(nrow = prod(unlist(dim_obs)), ncol = 1) + pointer_var_obs <- describe(var_obs) + } + if (is.null(nprocs)) { + nprocs <- detectCores() + } + # We calculate the % of total progress that each work piece represents so + # that progress bar can be updated properly + exp_work_piece_percent <- prod(dim_exp) / (prod(dim_obs) + prod(dim_exp)) + obs_work_piece_percent <- prod(dim_obs) / (prod(dim_obs) + prod(dim_exp)) + # Add some important extra fields in the work pieces before sending + exp_work_pieces <- lapply(exp_work_pieces, function (x) c(x, list(dataset_type = 'exp', dims = dim_exp, out_pointer = pointer_var_exp)))###, progress_amount = exp_work_piece_progress))) + obs_work_pieces <- lapply(obs_work_pieces, function (x) c(x, list(dataset_type = 'obs', dims = dim_obs, out_pointer = pointer_var_obs)))###, progress_amount = obs_work_piece_progress))) + work_pieces <- c(exp_work_pieces, obs_work_pieces) + # Calculate the progress %s that will be displayed and assign them to the + # appropriate work pieces + if (length(work_pieces)/nprocs >= 2 && !silent) { + if (length(work_pieces)/nprocs < 10) { + amount <- 100/ceiling(length(work_pieces)/nprocs) + reps <- ceiling(length(work_pieces)/nprocs) + } else { + amount <- 10 + reps <- 10 + } + progress_steps <- rep(amount, reps) + if (length(exp_work_pieces) == 0) { + selected_exp_pieces <- c() + } else if (length(exp_work_pieces) < floor(reps*exp_work_piece_percent) + 1) { + selected_exp_pieces <- length(exp_work_pieces) + progress_steps <- c(sum(head(progress_steps, + floor(reps*exp_work_piece_percent))), + tail(progress_steps, + ceiling(reps*obs_work_piece_percent))) + } else { + selected_exp_pieces <- round(seq(1, length(exp_work_pieces), + length.out = floor(reps*exp_work_piece_percent) + 1))[-1] + } + if (length(obs_work_pieces) == 0) { + selected_obs_pieces <- c() + } else if (length(obs_work_pieces) < ceiling(reps*obs_work_piece_percent) + 1) { + selected_obs_pieces <- length(obs_work_pieces) + progress_steps <- c(head(progress_steps, + floor(reps*exp_work_piece_percent)), + sum(tail(progress_steps, + ceiling(reps*obs_work_piece_percent)))) + } else { + selected_obs_pieces <- round(seq(1, length(obs_work_pieces), + length.out = ceiling(reps*obs_work_piece_percent) + 1))[-1] + } + selected_pieces <- c(selected_exp_pieces, selected_obs_pieces + length(exp_work_pieces)) + progress_steps <- paste0(' + ', round(progress_steps, 2), '%') + progress_message <- 'Progress: 0%' + } else { + progress_message <- '' + selected_pieces <- NULL + } + piece_counter <- 1 + step_counter <- 1 + work_pieces <- lapply(work_pieces, + function (x) { + wp <- c(x, list(is_2d_var = is_2d_var, grid = grid, remap = remap, + lon_limits = c(lonmin, lonmax), + lat_limits = c(latmin, latmax), + output = output, remapcells = remapcells, + single_dataset = single_dataset)) + if (piece_counter %in% selected_pieces) { + wp <- c(wp, list(progress_amount = progress_steps[step_counter])) + step_counter <<- step_counter + 1 + } + piece_counter <<- piece_counter + 1 + wp + }) + if (!silent) { + .message(paste("Will now proceed to read and process ", length(work_pieces), " data files:", sep = '')) + if (length(work_pieces) < 30) { + lapply(work_pieces, function (x) .message(x[['filename']], indent = 2)) + } else { + .message("The list of files is long. You can check it after Load() finishes in the output '$source_files'.", indent = 2, exdent = 5) + } + if (length(dim_obs) == 0) { + bytes_obs <- 0 + obs_dim_sizes <- '0' + } else { + bytes_obs <- prod(c(dim_obs, 8)) + obs_dim_sizes <- paste(na.omit(as.vector(dim_obs[c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon')])), collapse = ' x ') + } + if (length(dim_exp) == 0) { + bytes_exp <- 0 + exp_dim_sizes <- '0' + } else { + bytes_exp <- prod(c(dim_exp, 8)) + exp_dim_sizes <- paste(na.omit(as.vector(dim_exp[c('dataset', 'member', 'sdate', 'ftime', 'lat', 'lon')])), collapse = ' x ') + } + .message(paste("Total size of requested data: ", bytes_obs + bytes_exp, "bytes.")) + .message(paste("- Experimental data: (", exp_dim_sizes, ") x 8 bytes =", bytes_exp, "bytes."), indent = 2) + .message(paste("- Observational data: (", obs_dim_sizes, ") x 8 bytes =", bytes_obs, "bytes."), indent = 2) + .message("If size of requested data is close to or above the free shared RAM memory, R will crash.") + } + # Build the cluster of processes that will do the work and dispatch work pieces. + # The function .LoadDataFile is applied to each work package. This function will + # open the data file, regrid if needed, trim (select time steps, longitudes, + # latitudes, members), apply the mask, compute and apply the weights if needed, + # disable extreme values and store in the shared memory matrices. + if (nprocs == 1) { + found_files <- lapply(work_pieces, .LoadDataFile, silent = silent) + } else { + cluster <- makeCluster(nprocs, outfile = "") + # Open connections to keep track of progress + ###range_progress_ports <- c(49000, 49999) + ###progress_ports <- as.list(sample(range_progress_ports[2] - range_progress_ports[1], nprocs) + range_progress_ports[1]) + + # Open from master side + ###connection_set_up_job <- mcparallel({ + ### progress_connections <- vector('list', length(progress_ports)) + ### for (connection in 1:length(progress_ports)) { + ### attempts <- 0 + ### max_attempts <- 3 + ### while (is.null(progress_connections[[connection]]) && attempts < max_attempts) { + ### Sys.sleep(2) + ### suppressWarnings({ + ### progress_connections[[connection]] <- try({ + ### socketConnection(port = progress_ports[[connection]], open = 'w+b') + ### }, silent = TRUE) + ### }) + ### if (!('sockconn' %in% class(progress_connections[[connection]]))) { + ### progress_connections[[connection]] <- NULL + ### } + ### attempts <- attempts + 1 + ### } + ### } + + # And start polling the sockets and update progress bar + ### if (!any( lapply is.null!!! is.null(progress_connections))) { + ### progress <- 0.0 + ### pb <- txtProgressBar(0, 1, style = 3) + ### stop_polling <- FALSE + ### attempts <- 0 + ### max_attempts <- 3 + ### while (progress < 0.999 && !stop_polling) { + ### Sys.sleep(3) + ### progress_obtained <- lapply(progress_connections, function(x) as.numeric(readBin(x, 'double'))) + ### total_progress_obtained <- sum(unlist(progress_obtained)) + ### if (total_progress_obtained > 0) { + ### progress <- progress + total_progress_obtained + ### setTxtProgressBar(pb, progress) + ### attempts <- 0 + ### } else { + ### attempts <- attempts + 1 + ### if (attempts >= max_attempts) { + ### stop_polling <- TRUE + ### } + ### } + ### } + ### } + ###}) + + # Open from the workers sidtr(data) + ###open_connections <- clusterApply(cluster, progress_ports, + ### function (x) { + ### progress_connection <<- NULL + ### progress_connection <<- try({ + ### socketConnection(server = TRUE, port = x, open = 'w+b') + ### }) + ### if ('sockconn' %in% class(progress_connection)) { + ### TRUE + ### } else { + ### progress_connection <<- NULL + ### FALSE + ### } + ### }) + + ###if (!all(unlist(open_connections))) { + ### if (!silent) { + ### cat(paste("! Warning: failed to open connections in ports", process_track_ports[1], "to", process_track_ports[2], "to keep track of progress. Progress bar will not be displayed\n")) + ### } + ###} + + if (!silent) { + .message("Loading... This may take several minutes...") + if (progress_message != '') { + .message(progress_message, appendLF = FALSE) + } + } + # Send the heavy work to the workers + work_errors <- try({ + found_files <- clusterApplyLB(cluster, work_pieces, .LoadDataFile, silent = silent) + }) + stopCluster(cluster) + } + if (!silent) { + if (progress_message != '') { + .message("\n") + } + if (any(unlist(lapply(found_files, is.null)))) { + if (sum(unlist(lapply(found_files, is.null))) < 30) { + warning_text <- "The following files were not found in the file system. Filling with NA values instead.\n" + warning_text <- paste0(warning_text, do.call(paste, lapply(work_pieces[which(unlist(lapply(found_files, is.null)))], function (x) paste0(" ", x[['filename']], "\n")))) + .warning(warning_text) + } else { + .warning("Some files were not found in the file system. The list is long. You can check it in the output '$not_found_files'. Filling with NA values instead.") + } + } + } + source_files <- unlist(found_files[which(!unlist(lapply(found_files, is.null)))]) + not_found_files <- unlist(lapply(work_pieces[which(unlist(lapply(found_files, is.null)))], '[[', 'filename')) + + } else { + error_message <- "Error: No found files for any dataset. Check carefully the file patterns and correct either the pattern or the provided parameters:\n" + tags_to_find <- c('START_DATE', 'YEAR', 'MONTH', 'DAY', 'MEMBER_NUMBER') + position_of_tags <- na.omit(match(tags_to_find, names(replace_values))) + if (!is.null(exp)) { + lapply(exp, function (x) { + replace_values[["EXP_NAME"]] <- x[['name']] + replace_values[["NC_VAR_NAME"]] <- x[['nc_var_name']] + replace_values[["SUFFIX"]] <- x[['suffix']] + extra_vars <- names(x)[which(!(names(x) %in% exp_info_names))] + replace_values[extra_vars] <- x[extra_vars] + if (length(position_of_tags) > 0) { + quasi_final_path <- .ConfigReplaceVariablesInString(x[['path']], + replace_values[-position_of_tags], TRUE) + } else { + quasi_final_path <- .ConfigReplaceVariablesInString(x[['path']], + replace_values, TRUE) + } + error_message <<- paste0(error_message, paste0(quasi_final_path, '\n')) + replace_values[extra_vars] <- NULL + }) + } + if (!is.null(obs)) { + lapply(obs, function (x) { + replace_values[["OBS_NAME"]] <- x[['name']] + replace_values[["NC_VAR_NAME"]] <- x[['nc_var_name']] + replace_values[["SUFFIX"]] <- x[['suffix']] + extra_vars <- names(x)[which(!(names(x) %in% obs_info_names))] + replace_values[extra_vars] <- x[extra_vars] + if (length(position_of_tags) > 0) { + quasi_final_path <- .ConfigReplaceVariablesInString(x[['path']], + replace_values[-position_of_tags], TRUE) + } else { + quasi_final_path <- .ConfigReplaceVariablesInString(x[['path']], + replace_values, TRUE) + } + error_message <<- paste0(error_message, paste0(quasi_final_path, '\n')) + replace_values[extra_vars] <- NULL + }) + } + stop(error_message) + } + + }) + + if (class(errors) == 'try-error') { + invisible(list(load_parameters = load_parameters)) + } else { + # Before ending, the data is arranged in the common format, with the following + # dimension order: + # nmod/nobs, members, startdates, leadtimes, latitudes, longitudes + # and the metadata is generated following the conventions in downscaleR. + variable <- list(varName = var, level = NULL) + attr(variable, 'use_dictionary') <- FALSE + attr(variable, 'units') <- units + attr(variable, 'longname') <- var_long_name + attr(variable, 'description') <- 'none' + attr(variable, 'daily_agg_cellfun') <- 'none' + attr(variable, 'monthly_agg_cellfun') <- 'none' + attr(variable, 'verification_time') <- 'none' + + number_ftime <- NULL + if (is.null(var_exp)) { + mod_data <- NULL + } else { + dim_reorder <- length(dim_exp):1 + dim_reorder[2:3] <- dim_reorder[3:2] + old_dims <- dim_exp + dim_exp <- dim_exp[dim_reorder] + mod_data <- aperm(array(bigmemory::as.matrix(var_exp), dim = old_dims), dim_reorder) + attr(mod_data, 'dimensions') <- names(dim_exp) + names(dim(mod_data)) <- names(dim_exp) + number_ftime <- dim_exp[["ftime"]] + } + + if (is.null(var_obs)) { + obs_data <- NULL + } else { + dim_reorder <- length(dim_obs):1 + dim_reorder[2:3] <- dim_reorder[3:2] + old_dims <- dim_obs + dim_obs <- dim_obs[dim_reorder] + obs_data <- aperm(array(bigmemory::as.matrix(var_obs), dim = old_dims), dim_reorder) + attr(obs_data, 'dimensions') <- names(dim_obs) + names(dim(obs_data)) <- names(dim_obs) + if (is.null(number_ftime)) { + number_ftime <- dim_obs[["ftime"]] + } + } + + if (is.null(latitudes)) { + lat <- 0 + attr(lat, 'cdo_grid_name') <- 'none' + attr(lat, 'first_lat') <- 'none' + attr(lat, 'last_lat') <- 'none' + } else { + lat <- latitudes + attr(lat, 'cdo_grid_name') <- if (is.null(grid)) 'none' else grid + attr(lat, 'first_lat') <- tail(lat, 1) + attr(lat, 'last_lat') <- head(lat, 1) + } + attr(lat, 'projection') <- 'none' + + if (is.null(longitudes)) { + lon <- 0 + attr(lon, 'cdo_grid_name') <- 'none' + attr(lon, 'data_across_gw') <- 'none' + attr(lon, 'array_across_gw') <- 'none' + attr(lon, 'first_lon') <- 'none' + attr(lon, 'last_lon') <- 'none' + } else { + lon <- longitudes + attr(lon, 'cdo_grid_name') <- if (is.null(grid)) 'none' else grid + attr(lon, 'data_across_gw') <- data_across_gw + attr(lon, 'array_across_gw') <- array_across_gw + attr(lon, 'first_lon') <- lon[which.min(abs(lon - lonmin))] + attr(lon, 'last_lon') <- lon[which.min(abs(lon - lonmax))] + } + attr(lon, 'projection') <- 'none' + + dates <- list() + ## we must put a start and end time for each prediction c(start date, forecast time) + if (storefreq == 'minutely') { + store_period <- 'min' + } else if (storefreq == 'hourly') { + store_period <- 'hour' + } else if (storefreq == 'daily') { + store_period <- 'DSTday' + } else if (storefreq == 'monthly') { + store_period <- 'month' + } + + addTime <- function(date, period, n = 1) { + seq(date, by = paste(n, period), length = 2)[2] + } + + # We build dates, a list with components start and end. + # Start is a list with as many components as start dates. + # Each component is a vector of the initial POSIXct date of each + # forecast time step + dates[["start"]] <- do.call(c, lapply(sdates, + function(x) { + do.call(c, lapply((0:(number_ftime - 1)) * sampleperiod, + function(y) { + addTime(as.POSIXct(x, format = "%Y%m%d"), store_period, y + leadtimemin - 1) + })) + })) + # end is similar to start, but contains the end dates of each forecast + # time step + dates[["end"]] <- do.call(c, lapply(dates[["start"]], + function(x) { + do.call(c, lapply(x, + function(y) { + addTime(y, store_period) + })) + })) + + tags_to_find <- c('START_DATE', 'MEMBER_NUMBER', 'YEAR', 'MONTH', 'DAY') + position_of_tags <- na.omit(match(tags_to_find, names(replace_values))) + if (length(position_of_tags) > 0) { + replace_values <- replace_values[-position_of_tags] + } + models <- NULL + if (length(exp) > 0 && !is.null(dim_exp)) { + models <- list() + for (jmod in 1:length(exp)) { + member_names <- paste0("Member_", 1:nmember[jmod]) + models[[exp[[jmod]][["name"]]]] <- list( + InitializationDates = lapply(member_names, + function(x) { + do.call(c, lapply(sdates, function(y) { + as.POSIXct(y, format = "%Y%m%d") + })) + }), + Members = member_names) + names(models[[exp[[jmod]][["name"]]]]$InitializationDates) <- member_names + attr(models[[exp[[jmod]][["name"]]]], 'dataset') <- exp[[jmod]][["name"]] + attr(models[[exp[[jmod]][["name"]]]], 'source') <- { + quasi_final_path <- .ConfigReplaceVariablesInString(exp[[jmod]][['path']], + replace_values, TRUE) + if ((nchar(quasi_final_path) - + nchar(gsub("/", "", quasi_final_path)) > 2) && + (length(sdates) > 1 && !is_file_per_member_exp[jmod])) { + parts <- strsplit(quasi_final_path, "/")[[1]] + paste(parts[-length(parts)], sep = "", collapse = "/") + } else { + quasi_final_path + } + } + attr(models[[exp[[jmod]][["name"]]]], 'URL') <- 'none' + } + } + + observations <- NULL + if (length(obs) > 0 && !is.null(dim_obs)) { + observations <- list() + for (jobs in 1:length(obs)) { + member_names <- paste0("Member_", 1:nmemberobs[jobs]) + observations[[obs[[jobs]][["name"]]]] <- list( + InitializationDates = lapply(member_names, + function(x) { + do.call(c, lapply(sdates, function(y) { + as.POSIXct(y, format = "%Y%m%d") + })) + }), + Members = member_names) + names(observations[[obs[[jobs]][["name"]]]]$InitializationDates) <- member_names + attr(observations[[obs[[jobs]][["name"]]]], 'dataset') <- obs[[jobs]][["name"]] + attr(observations[[obs[[jobs]][["name"]]]], 'source') <- { + quasi_final_path <- .ConfigReplaceVariablesInString(obs[[jobs]][['path']], + replace_values, TRUE) + if ((nchar(quasi_final_path) - + nchar(gsub("/", "", quasi_final_path)) > 2) && + !is_file_per_dataset_obs[jobs]) { + parts <- strsplit(quasi_final_path, "/")[[1]] + paste(parts[-length(parts)], sep = "", collapse = "/") + } else { + quasi_final_path + } + } + attr(observations[[obs[[jobs]][["name"]]]], 'URL') <- 'none' + } + } + + invisible(list(mod = mod_data, + obs = obs_data, + lon = lon, + lat = lat, + Variable = variable, + Datasets = list(exp = models, obs = observations), + Dates = dates, + when = Sys.time(), + source_files = source_files, + not_found_files = not_found_files, + load_parameters = load_parameters)) + } +} diff --git a/R/Plot2VarsVsLTime.R b/R/Plot2VarsVsLTime.R new file mode 100644 index 0000000..1e2fc6d --- /dev/null +++ b/R/Plot2VarsVsLTime.R @@ -0,0 +1,258 @@ +#'Plot Two Scores With Confidence Intervals In A Common Plot +#' +#'Plots two input variables having the same dimensions in a common plot.\cr +#'One plot for all experiments.\cr +#'Input variables should have dimensions (nexp/nmod, nltime). +#' +#'@param var1 Matrix of dimensions (nexp/nmod, nltime). +#'@param var2 Matrix of dimensions (nexp/nmod, nltime). +#'@param toptitle Main title, optional. +#'@param ytitle Title of Y-axis, optional. +#'@param monini Starting month between 1 and 12. Default = 1. +#'@param freq 1 = yearly, 12 = monthly, 4 = seasonal, ... Default = 12. +#'@param nticks Number of ticks and labels on the x-axis, optional. +#'@param limits c(lower limit, upper limit): limits of the Y-axis, optional. +#'@param listexp List of experiment names, up to three, optional. +#'@param listvars List of names of input variables, optional. +#'@param biglab TRUE/FALSE for presentation/paper plot. Default = FALSE. +#'@param hlines c(a, b, ...) Add horizontal black lines at Y-positions a, b, +#' ...\cr +#' Default: NULL. +#'@param leg TRUE/FALSE if legend should be added or not to the plot. +#' Default = TRUE. +#'@param siglev TRUE/FALSE if significance level should replace confidence +#' interval.\cr +#' Default = FALSE. +#'@param sizetit Multiplicative factor to change title size, optional. +#'@param show_conf TRUE/FALSE to show/not confidence intervals for input +#' variables. +#'@param fileout Name of output file. Extensions allowed: eps/ps, jpeg, png, +#' pdf, bmp and tiff. \cr +#' Default = 'output_plot2varsvsltime.eps' +#'@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 ... 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 fig font font.axis font.lab font.main font.sub lend +#' lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page pch plt +#' smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +#' For more information about the parameters see `par`. +#' +#'@details +#'Examples of input:\cr +#'------------------\cr\cr +#'RMSE error for a number of experiments and along lead-time: (nexp, nltime) +#' +#'@keywords dynamic +#'@author History:\cr +#'1.0 - 2013-03 (I. Andreu-Burillo, \email{isabel.andreu-burillo@@ic3.cat}) +#' - Original code +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'runmean_months <- 12 +#'dim_to_smooth <- 4 # Smooth along lead-times +#'smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +#'smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +#'dim_to_mean <- 2 # Mean along members +#'required_complete_row <- 3 # Discard start dates that contain NA along lead-times +#'leadtimes_per_startdate <- 60 +#'rms <- RMS(Mean1Dim(smooth_ano_exp, dim_to_mean), +#' Mean1Dim(smooth_ano_obs, dim_to_mean), +#' compROW = required_complete_row, +#' limits = c(ceiling((runmean_months + 1) / 2), +#' leadtimes_per_startdate - floor(runmean_months / 2))) +#'smooth_ano_exp_m_sub <- smooth_ano_exp - InsertDim(Mean1Dim(smooth_ano_exp, 2, +#' narm = TRUE), 2, dim(smooth_ano_exp)[2]) +#'spread <- Spread(smooth_ano_exp_m_sub, c(2, 3)) +#' \donttest{ +#'Plot2VarsVsLTime(InsertDim(rms[, , , ], 1, 1), spread$sd, +#' toptitle = 'RMSE and spread', monini = 11, freq = 12, +#' listexp = c('CMIP5 IC3'), listvar = c('RMSE', 'spread'), +#' fileout = 'plot2vars.eps') +#' } +#' +#'@importFrom grDevices png jpeg postscript pdf svg bmp tiff postscript dev.cur dev.new dev.off +#'@importFrom stats ts +#'@export +Plot2VarsVsLTime <- function(var1, var2, toptitle = '', ytitle = '', monini = 1, + freq = 12, nticks = NULL, limits = NULL, listexp = + c('exp1', 'exp2', 'exp3'), listvars = c('var1', + 'var2'), biglab = FALSE, hlines = NULL, leg = TRUE, + siglev = FALSE, sizetit = 1, show_conf = TRUE, + fileout = 'output_plot2varsvsltime.eps', + 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", "fin", "lab", "las", "lty", "lwd", "mai", "mgp", "new", "pin", "ps", "pty") + 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 + } + + # + nvars <- 2 + + if (length(dim(var1)) != length(dim(var2))) { + print("the two input variables should have the same dimensions") + stop() + } + if (length(dim(var1)) >= 4) { + print("dimensions of input variables should be 3") + stop() + } + nleadtime <- dim(var1)[3] + nexp <- dim(var1)[1] + var <- array(dim = c(nvars, nexp, 3, nleadtime)) + for (jvar in 1:nvars) { + varname <- paste("var", as.character(jvar), sep = "") + var[jvar, , , ] <- get(varname) + rm(varname) + } + + if (is.null(limits) == TRUE) { + ll <- min(var1, na.rm = TRUE) + ul <- max(var1, na.rm = TRUE) + if (biglab) { + ul <- ul + 0.4 * (ul - ll) + } else { + ul <- ul + 0.3 * (ul - ll) + } + } else { + ll <- limits[1] + ul <- limits[2] + } + lastyear <- (monini + (nleadtime - 1) * 12 / freq - 1) %/% 12 + lastmonth <- (monini + (nleadtime - 1) * 12 / freq - 1) %% 12 + 1 + empty_ts <- ts(start = c(0000, (monini - 1) %/% (12 / freq) + 1), + end = c(lastyear, (lastmonth - 1) %/% (12 / freq) + 1), + frequency = freq) + empty <- array(dim = length(empty_ts)) + # + # Define some plot parameters + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + if (is.null(nticks)) { + if (biglab) { + nticks <- 5 + } else { + nticks <- 10 + } + } + labind <- seq(1, nleadtime, max(nleadtime %/% nticks, 1)) + months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", + "Oct", "Nov", "Dec") + labyear <- ((labind - 1) * 12 / freq + monini - 1) %/% 12 + labmonth <- months[((labind - 1) * 12 / freq + monini - 1) %% 12 + 1] + for (jx in 1:length(labmonth)) { + y2o3dig <- paste("0", as.character(labyear[jx]), sep = "") + labmonth[jx] <- paste(labmonth[jx], "\nYr ", substr(y2o3dig, nchar(y2o3dig) + - 1, nchar(y2o3dig)), sep = "") + } + color <- c("red1", "dodgerblue1", "green1", "orange1", "lightblue1", + "deeppink1", "mediumpurple1", "lightgoldenrod1", "olivedrab1", + "mediumorchid1") + type <- c(1, 3) + if (siglev == TRUE) { + lines <- c("n", "l", "n") + } + else{ + lines <- c("l", "l", "l") + } + thickness <- array(dim = c(3)) + thickness[1] <- c(1) + thickness[2] <- c(8) + thickness[3] <- thickness[1] + + # + # Define plot layout + # ~~~~~~~~~~~~~~~~~~~~ + # + + # 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) + } + + # Load the user parameters + par(userArgs) + + if (biglab) { + par(mai = c(1.25, 1.4, 0.5, 1), mgp = c(4, 2.5, 0)) + par(cex = 1.3, cex.lab = 2, cex.axis = 1.8) + cexmain <- 2.2 + legsize <- 1.5 + } else { + par(mai = c(1, 1.1, 0.5, 0), mgp = c(3, 1.8, 0)) + par(cex = 1.3, cex.lab = 1.5, cex.axis = 1.1) + cexmain <- 1.5 + legsize <- 1 + } + plot(empty, ylim = c(ll, ul), xlab = "Time (months)", ylab = ytitle, + main = toptitle, cex.main = cexmain * sizetit, axes = FALSE) + axis(1, at = labind, labels = labmonth) + axis(2) + box() + if (is.null(hlines) != TRUE) { + for (jy in 1:length(hlines)) { + par(new = TRUE) + abline(h = hlines[jy]) + } + } + # + # Loop on experimental data + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + legendnames <- array(dim = nexp * nvars) + legendthick <- array(dim = nexp * nvars) + legendsty <- array(dim = nexp * nvars) + legendcol <- array(dim = nexp * nvars) + if (show_conf == TRUE) { + start_line <- 3 + end_line <- 1 + } else { + start_line <- 2 + end_line <- 2 + } + for (jint in seq(start_line, end_line, -1)) { + ind <- 1 + for (jexp in 1:nexp) { + for (jvar in 1:nvars) { + par(new = TRUE) + plot(var[jvar, jexp, jint, ], type = lines[jint], ylim = c(ll, ul), + col = color[jexp], lty = type[jvar], lwd = thickness[jint], + ylab = "", xlab = "", axes = FALSE) + legendnames[ind] <- paste(listexp[jexp], listvars[jvar]) + legendthick[ind] <- 2 + legendsty[ind] <- type[jvar] + legendcol[ind] <- color[jexp] + ind <- ind + 1 + } + } + } + if (leg) { + legend(1, ul, legendnames, lty = legendsty, lwd = legendthick, + col = legendcol, cex = legsize) + } + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() +} diff --git a/R/PlotACC.R b/R/PlotACC.R new file mode 100644 index 0000000..872327f --- /dev/null +++ b/R/PlotACC.R @@ -0,0 +1,251 @@ +#'Plot Plumes/Timeseries Of Anomaly Correlation Coefficients +#' +#'Plots plumes/timeseries of ACC from an array with dimensions +#'(output from \code{ACC()}): \cr +#'c(nexp, nobs, nsdates, nltime, 4)\cr +#'where the fourth dimension is of length 4 and contains the lower limit of +#'the 95\% confidence interval, the ACC, the upper limit of the 95\% +#'confidence interval and the 95\% significance level given by a one-sided +#'T-test. +#' +#'@param ACC ACC matrix with with dimensions:\cr +#' c(nexp, nobs, nsdates, nltime, 4)\cr +#' with the fourth dimension of length 4 containing the lower limit of the +#' 95\% confidence interval, the ACC, the upper limit of the 95\% confidence +#' interval and the 95\% significance level. +#'@param sdates List of startdates: c('YYYYMMDD','YYYYMMDD'). +#'@param toptitle Main title, optional. +#'@param sizetit Multiplicative factor to scale title size, optional. +#'@param ytitle Title of Y-axis for each experiment: c('',''), optional. +#'@param limits c(lower limit, upper limit): limits of the Y-axis, optional. +#'@param legends List of flags (characters) to be written in the legend, +#' optional. +#'@param freq 1 = yearly, 12 = monthly, 4 = seasonal, ... Default: 12. +#'@param biglab TRUE/FALSE for presentation/paper plot, Default = FALSE. +#'@param fill TRUE/FALSE if filled confidence interval. Default = FALSE. +#'@param linezero TRUE/FALSE if a line at y=0 should be added. Default = FALSE. +#'@param points TRUE/FALSE if points instead of lines. Default = TRUE.\cr +#' Must be TRUE if only 1 leadtime. +#'@param vlines List of x location where to add vertical black lines, optional. +#'@param fileout Name of output file. Extensions allowed: eps/ps, jpeg, png, +#' pdf, bmp and tiff. \cr +#' Default = 'output_PlotACC.eps' +#'@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 fig fin font font.axis font.lab font.main font.sub +#' lend lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page +#' plt smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog\cr +#' For more information about the parameters see `par`. +#' +#'@keywords dynamic +#'@author History:\cr +#'0.1 - 2013-08 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to CRAN +#'@examples +#'# See examples on Load() to understand the first lines in this example +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' leadtimemin = 1, leadtimemax = 4, output = 'lonlat', +#' latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#'sampleData$mod <- Season(sampleData$mod, 4, 11, 12, 2) +#'sampleData$obs <- Season(sampleData$obs, 4, 11, 12, 2) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'acc <- ACC(Mean1Dim(sampleData$mod, 2), +#' Mean1Dim(sampleData$obs, 2)) +#' \donttest{ +#'PlotACC(acc$ACC, startDates, toptitle = "Anomaly Correlation Coefficient") +#' +#' } +#'@importFrom grDevices dev.cur dev.new dev.off +#'@importFrom stats ts +#'@export +PlotACC <- function(ACC, sdates, toptitle = "", sizetit = 1, ytitle = "", + limits = NULL, legends = NULL, freq = 12, biglab = FALSE, + fill = FALSE, linezero = FALSE, points = TRUE, vlines = NULL, + fileout = "output_PlotACC.eps", + 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", "lab", "las", "lty", "lwd", "mai", "mgp", "new", "pch", "pin", "ps", "pty") + 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 + } + + # + if (length(dim(ACC)) != 5 | dim(ACC)[5] != 4) { + stop("5 dim needed : c(nexp, nobs, nsdates, nltime, 4)") + } + nexp <- dim(ACC)[1] + nobs <- dim(ACC)[2] + nleadtime <- dim(ACC)[4] + nsdates <- dim(ACC)[3] + if (is.null(limits) == TRUE) { + ll <- min(ACC, na.rm = TRUE) + ul <- max(ACC, na.rm = TRUE) + if (biglab) { + ul <- ul + 0.3 * (ul - ll) + } else { + ul <- ul + 0.2 * (ul - ll) + } + } else { + ll <- limits[1] + ul <- limits[2] + } + yearinit <- as.integer(substr(sdates[1], 1, 4)) + moninit <- as.integer(substr(sdates[1], 5, 6)) + lastyear <- as.integer(substr(sdates[nsdates], 1, 4)) + (moninit + ( + nleadtime - 1) * 12 / freq - 1) %/% 12 + lastmonth <- (moninit + (nleadtime - 1) * (12 / freq) - 1) %% 12 + 1 + empty_ts <- ts(start = c(yearinit, (moninit - 1) %/% (12 / freq) + 1), + end = c(lastyear, (lastmonth - 1) %/% (12 / freq) + 1), + frequency = freq) + color <- c("red4", "dodgerblue4", "lightgoldenrod4", "deeppink4", + "mediumpurple4", "green4", "orange4", "lightblue4", "mediumorchid4", + "olivedrab4") + colorblock <- c("red1", "dodgerblue1", "lightgoldenrod1", "deeppink1", + "mediumpurple1", "green1", "orange1", "lightblue1", + "mediumorchid1", "olivedrab1") + + # 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) + } + + # Load the user parameters + par(userArgs) + + if (biglab) { + par(mai = c(1, 1.1, 0.5, 0), mgp = c(2.8, 0.9, 0)) + par(cex = 1.3, cex.lab = 2, cex.axis = 1.8) + cexmain <- 2.2 + legsize <- 1.5 + } else { + par(mai = c(0.8, 0.8, 0.5, 0.1), mgp = c(2, 0.5, 0)) + par(cex = 1.3, cex.lab = 1.5, cex.axis = 1.1) + cexmain <- 1.5 + legsize <- 1 + } + plot(empty_ts, ylim = c(ll, ul), xlab = "Time (years)", ylab = ytitle, + main = toptitle, cex.main = cexmain * sizetit) + for (jexp in 1:nexp) { + for (jobs in 1:nobs) { + numcol <- jobs + (jexp - 1) * nobs + for (jdate in 1:nsdates) { + year0 <- as.integer(substr(sdates[jdate], 1, 4)) + mon0 <- as.integer(substr(sdates[jdate], 5, 6)) + start <- (year0 - yearinit) * freq + 1 + end <- start + nleadtime - 1 + var <- array(dim = c(3, length(empty_ts))) + var[, start:end] <- t(ACC[jexp, jobs, jdate, , 1:3]) + if (fill) { + par(new = TRUE) + bordup <- ACC[jexp, jobs, jdate, , 3] + borddown <- ACC[jexp, jobs, jdate, , 1] + tmp <- c(start:end) + xout <- is.na(bordup + borddown) + tmp <- tmp[which(xout == FALSE)] + xx <- c(tmp, rev(tmp)) + bordup <- bordup[which(xout == FALSE)] + borddown <- borddown[which(xout == FALSE)] + yy <- c(bordup, rev(borddown)) + if (jdate == 1) { + matplot(t(var), type = "l", lty = 1, lwd = 1, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE) + } + polygon(xx, yy, col = colorblock[numcol], border = NA) + } + if (points) { + par(new = TRUE) + plot(var[2, ], type = "p", lty = 1, lwd = 6, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE, + cex = 0.6) + par(new = TRUE) + plot(var[1, ], type = "p", pch = 6, lwd = 3, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE, + cex = 0.6) + par(new = TRUE) + plot(var[3, ], type = "p", pch = 2, lwd = 3, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE, + cex = 0.6) + par(new = TRUE) + for (jind in start:end) { + lines(c(jind, jind), var[c(1, 3), jind], lwd = 1, + ylim = c(ll, ul), col = color[numcol], xlab = "", + ylab = "", axes = FALSE) + } + } else { + par(new = TRUE) + plot(var[2, ], type = "l", lty = 1, lwd = 4, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE) + par(new = TRUE) + plot(var[1, ], type = "l", lty = 1, lwd = 1, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE) + par(new = TRUE) + plot(var[3, ], type = "l", lty = 1, lwd = 1, ylim = c(ll, ul), + col = color[numcol], xlab = "", ylab = "", axes = FALSE) + } + } + } + } + if (linezero) { + abline(h = 0, col = "black") + } + if (is.null(vlines) == FALSE) { + for (x in vlines) { + abline(v = x, col = "black") + } + } + if (is.null(legends) == FALSE) { + if (points) { + legend(0, ul, legends[1:(nobs * nexp)], lty = 3, lwd = 10, + col = color[1:(nobs * nexp)], cex = legsize) + } else { + legend(0, ul, legends[1:(nobs * nexp)], lty = 1, lwd = 4, + col = color[1:(nobs * nexp)], cex = legsize) + } + } + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() +} diff --git a/R/PlotAno.R b/R/PlotAno.R new file mode 100644 index 0000000..922806a --- /dev/null +++ b/R/PlotAno.R @@ -0,0 +1,304 @@ +#'Plot Raw Or Smoothed Anomalies +#' +#'Plots timeseries of raw or smoothed anomalies of any variable output from +#'\code{Load()} or \code{Ano()} or or \code{Ano_CrossValid()} or +#'\code{Smoothing()}. +#' +#'@param exp_ano Array containing the experimental data:\cr +#' c(nmod/nexp, nmemb/nparam, nsdates, nltime). +#'@param obs_ano Optional matrix containing the observational data:\cr +#' c(nobs, nmemb, nsdates, nltime) +#'@param sdates List of starting dates: c('YYYYMMDD','YYYYMMDD'). +#'@param toptitle Main title for each experiment: c('',''), optional. +#'@param ytitle Title of Y-axis for each experiment: c('',''), optional. +#'@param limits c(lower limit, upper limit): limits of the Y-axis, optional. +#'@param legends List of observational dataset names, optional. +#'@param freq 1 = yearly, 12 = monthly, 4 = seasonal, ... Default: 12. +#'@param biglab TRUE/FALSE for presentation/paper plot. Default = FALSE. +#'@param fill TRUE/FALSE if the spread between members should be filled. +#' Default = TRUE. +#'@param memb TRUE/FALSE if all members/only the ensemble-mean should be +#' plotted.\cr +#' Default = TRUE. +#'@param ensmean TRUE/FALSE if the ensemble-mean should be plotted. +#' Default = TRUE. +#'@param linezero TRUE/FALSE if a line at y=0 should be added. +#' Default = FALSE. +#'@param points TRUE/FALSE if points instead of lines should be shown. +#' Default = FALSE. +#'@param vlines List of x location where to add vertical black lines, optional. +#'@param sizetit Multiplicative factor to scale title size, optional. +#'@param fileout Name of the output file for each experiment: c('',''). +#' Extensions allowed: eps/ps, jpeg, png, pdf, bmp and tiff. If filenames +#' with different extensions are passed, it will be considered only the first +#' one and it will be extended to the rest. \cr +#' Default = c('output1_plotano.eps', 'output2_plotano.eps', +#' 'output3_plotano.eps', 'output4_plotano.eps', +#' 'output5_plotano.eps') +#'@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 fig font font.axis font.lab font.main font.sub lend +#' lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page plt smo +#' srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +#' For more information about the parameters see `par`. +#' +#'@keywords dynamic +#'@author History:\cr +#'0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to CRAN +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'runmean_nb_months <- 12 +#'dim_to_smooth <- 4 # Smooth along lead-times +#'smooth_ano_exp <- Smoothing(ano_exp, runmean_nb_months, dim_to_smooth) +#'smooth_ano_obs <- Smoothing(ano_obs, runmean_nb_months, dim_to_smooth) +#' \donttest{ +#'PlotAno(smooth_ano_exp, smooth_ano_obs, startDates, +#' toptitle = paste('smoothed anomalies'), ytitle = c('K', 'K', 'K'), +#' legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano.eps') +#' } +#' +#'@importFrom grDevices dev.cur dev.new dev.off +#'@importFrom stats ts +#'@export +PlotAno <- function(exp_ano, obs_ano = NULL, sdates, toptitle = rep('', 15), + ytitle = rep('', 15), limits = NULL, legends = NULL, + freq = 12, biglab = FALSE, fill = TRUE, memb = TRUE, + ensmean = TRUE, linezero = FALSE, points = FALSE, + vlines = NULL, sizetit = 1, + fileout = paste0('output', 1:5, '_plotano.eps'), + 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", "fin", "lab", "las", "lty", "lwd", "mai", "mgp", "new", "pch", "pin", "ps", "pty") + 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 + } + + # + # Get some arguments + # ~~~~~~~~~~~~~~~~~~~~ + # + if (length(dim(exp_ano)) != 4 ) { + stop("4 dim needed : c(nexp/nobs, nmemb, nsdates, nltime)") + } + nexp <- dim(exp_ano)[1] + nmemb <- dim(exp_ano)[2] + nleadtime <- dim(exp_ano)[4] + nsdates <- dim(exp_ano)[3] + if (is.null(obs_ano) == FALSE) { + nobs <- dim(obs_ano)[1] + if (length(dim(obs_ano)) != 4 ) { + stop("4 dim needed : c(nexp/nobs, nmemb, nsdates, nltime)") + } + if (dim(obs_ano)[3] != nsdates | dim(obs_ano)[4] != nleadtime ) { + stop("obs and exp must have same number of sdates & ltimes") + } + } else { + nobs <- 0 + } + if (is.null(limits) == TRUE) { + if (memb) { + ll <- min(min(exp_ano, na.rm = TRUE), min(obs_ano, na.rm = TRUE), na.rm = TRUE) + ul <- max(max(exp_ano, na.rm = TRUE), max(obs_ano, na.rm = TRUE), na.rm = TRUE) + } + else{ + ll <- min(min(Mean1Dim(exp_ano, 2), na.rm = TRUE), min(obs_ano, na.rm = TRUE), + na.rm = TRUE) + ul <- max(max(Mean1Dim(exp_ano, 2), na.rm = TRUE), max(obs_ano, na.rm = TRUE), + na.rm = TRUE) + } + if (nobs > 0) { + if (biglab) { + ul <- ul + 0.3 * (ul - ll) + } else { + ul <- ul + 0.2 * (ul - ll) + } + } + } else { + ll <- limits[1] + ul <- limits[2] + } + # + # Define some plot parameters + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + yearinit <- as.integer(substr(sdates[1], 1, 4)) + moninit <- as.integer(substr(sdates[1], 5, 6)) + lastyear <- as.integer(substr(sdates[nsdates], 1, 4)) + (moninit + ( + nleadtime - 1) * 12 / freq - 1) %/% 12 + lastmonth <- (moninit + (nleadtime - 1) * (12 / freq) - 1) %% 12 + 1 + empty_ts <- ts(start = c(yearinit, (moninit - 1) %/% (12 / freq) + 1), + end = c(lastyear, (lastmonth - 1) %/% (12 / freq) + 1), + frequency = freq) + color <- c("red4", "orange4", "lightgoldenrod4", "olivedrab4", "green4", + "lightblue4", "dodgerblue4", "mediumpurple4", "mediumorchid4", + "deeppink4") + color <- c(color, color, color, color, color, color, color, color, color, + color, color) + colorblock <- c("red1", "orange1", "lightgoldenrod1", "olivedrab1", "green1", + "lightblue1", "dodgerblue1", "mediumpurple1", "mediumorchid1", + "deeppink1") + colorblock <- c(colorblock, colorblock, colorblock, colorblock, colorblock, + colorblock, colorblock, colorblock, colorblock, colorblock) + type <- c(1, 3, 2, 4) + thickness <- c(1, 3, 2, 2) + # + # Loop on the experiments : one plot for each + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + for (jexp in 1:nexp) { + # + # Define plot layout + # ~~~~~~~~~~~~~~~~~~~~ + # + + # Open connection to graphical device + if (!is.null(fileout)) { + saveToFile(fileout[jexp]) + } else if (names(dev.cur()) == 'null device') { + dev.new(units = size_units, res = res, width = width, height = height) + } + + + # Load the user parameters + par(userArgs) + + if (biglab) { + par(mai = c(1, 1.1, 0.5, 0), mgp = c(2.8, 0.9, 0)) + par(cex = 1.3, cex.lab = 2, cex.axis = 1.8) + cexmain <- 2.2 + legsize <- 1.5 + } else { + par(mai = c(0.8, 0.8, 0.5, 0.3), mgp = c(2, 0.5, 0)) + par(cex = 1.3, cex.lab = 1.5, cex.axis = 1.1) + cexmain <- 1.5 + legsize <- 1 + } + plot(empty_ts, ylim = c(ll, ul), xlab = "Time (years)", ylab = ytitle[jexp], + main = toptitle[jexp], cex.main = cexmain * sizetit) + # + # Plot experimental data + all observational datasets sdate by sdate + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + for (jdate in 1:nsdates) { + year0 <- as.integer(substr(sdates[jdate], 1, 4)) + mon0 <- as.integer(substr(sdates[jdate], 5, 6)) + start <- (year0 - yearinit) * freq + 1 + end <- start + nleadtime - 1 + var <- array(dim = c(nmemb, length(empty_ts))) + var[, start:end] <- exp_ano[jexp, , jdate, ] + # + # Compute parameters for filling max-min over members + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + if (fill) { + par(new = TRUE) + bordup <- array(dim = nleadtime) + borddown <- array(dim = nleadtime) + for (jt in 1:nleadtime) { + bordup[jt] <- max(exp_ano[jexp, , jdate, jt], na.rm = TRUE) + borddown[jt] <- min(exp_ano[jexp, , jdate, jt], na.rm = TRUE) + } + tmp <- c(start:end) + xout <- is.na(bordup + borddown) + tmp <- tmp[which(xout == FALSE)] + xx <- c(tmp, rev(tmp)) + bordup <- bordup[which(xout == FALSE)] + borddown <- borddown[which(xout == FALSE)] + yy <- c(bordup, rev(borddown)) + # + # Plotting + # ~~~~~~~~~~ + # + if (jdate == 1) { + matplot(t(var), type = "l", lty = 1, lwd = 1, ylim = c(ll, ul), + col = color[jdate], xlab = "", ylab = "", axes = FALSE) + } + # Max-min member range + polygon(xx, yy, col = colorblock[jdate], border = NA) + } + if (ensmean) { # Ensemble-mean + par(new = TRUE) + if (points) { + plot(Mean1Dim(t(var), 2), type = "p", lty = 1, lwd = 4, + ylim = c(ll, ul), col = color[jdate], xlab = "", ylab = "", + axes = FALSE) + } else { + plot(Mean1Dim(t(var), 2), type = "l", lty = 1, lwd = 4, + ylim = c(ll, ul), col = color[jdate], xlab = "", ylab = "", + axes = FALSE) + } + } + if (memb) { + par(new = TRUE) # All members + if (points) { + matpoints(t(var), type = "p", lty = 1, lwd = 1, pch = 20, + ylim = c(ll, ul), col = color[jdate], xlab = "", ylab = "", + axes = FALSE) + } else { + matplot(t(var), type = "l", lty = 1, lwd = 1, ylim = c(ll, ul), + col = color[jdate], xlab = "", ylab = "", axes = FALSE) + } + } + if (nobs > 0) { + for (jobs in 1:nobs) { + for (jmemb in 1:dim(obs_ano)[2]) { + var <- array(dim = length(empty_ts)) + var[start:end] <- obs_ano[jobs, jmemb, jdate, ] + par(new = TRUE) # Observational datasets + if (points) { + plot(var, type = "p", lty = 1, lwd = 4, pch = 20, + ylim = c(ll, ul), col = 1, ylab = "", xlab = "", + axes = FALSE) + } else { + plot(var, lty = type[jobs], lwd = thickness[jobs], type = "l", + ylim = c(ll, ul), col = 1, ylab = "", xlab = "", + axes = FALSE) + } + } + } + } + } + if (linezero) { + abline(h = 0, col = "black") + } + if (is.null(vlines) == FALSE) { + for (x in vlines) { + abline(v = x, col = "black") + } + } + if (is.null(legends) == FALSE) { + if (points) { + legend('topleft', legends[1:nobs], lty = 3, lwd = 10, col = 1, + cex = legsize) + } else { + legend('topleft', ul, legends[1:nobs], lty = type[1:nobs], + lwd = thickness[1:nobs], col = 1, cex = legsize) + } + } + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() + } +} diff --git a/R/PlotBoxWhisker.R b/R/PlotBoxWhisker.R new file mode 100644 index 0000000..46c5335 --- /dev/null +++ b/R/PlotBoxWhisker.R @@ -0,0 +1,243 @@ +#'Box-And-Whisker Plot of Time Series with Ensemble Distribution +#' +#'Produce time series of box-and-whisker plot showing the distribution of the +#'members of a forecast vs. the observed evolution. The correlation between +#'forecast and observational data is calculated and displayed. Only works for +#'n-monthly to n-yearly time series. +#' +#'@param exp Forecast array of multi-member time series, e.g., the NAO index +#' of one experiment. The expected dimensions are +#' c(members, start dates/forecast horizons). A vector with only the time +#' dimension can also be provided. Only monthly or lower frequency time +#' series are supported. See parameter freq. +#'@param obs Observational vector or array of time series, e.g., the NAO index +#' of the observations that correspond the forecast data in \code{exp}. +#' The expected dimensions are c(start dates/forecast horizons) or +#' c(1, start dates/forecast horizons). Only monthly or lower frequency time +#' series are supported. See parameter freq. +#'@param toptitle Character string to be drawn as figure title. +#'@param ytitle Character string to be drawn as y-axis title. +#'@param monini Number of the month of the first time step, from 1 to 12. +#'@param yearini Year of the first time step. +#'@param freq Frequency of the provided time series: 1 = yearly, 12 = monthly, +# 4 = seasonal, ... Default = 12. +#'@param expname Experimental dataset name. +#'@param obsname Name of the observational reference dataset. +#'@param drawleg TRUE/FALSE: whether to draw the legend or not. +#'@param fileout Name of output file. Extensions allowed: eps/ps, jpeg, png, +#' pdf, bmp and tiff. \cr +#' Default = 'output_PlotBox.ps'. +#'@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 ... Arguments to be passed to the method. Only accepts the following +#' graphical parameters:\cr +#' ann ask bg cex.lab cex.sub cin col.axis col.lab col.main col.sub cra crt +#' csi cxy err family fg fig font font.axis font.lab font.main font.sub lend +#' lheight ljoin lmitre mex mfcol mfrow mfg mkh oma omd omi page pin plt pty +#' smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +#' For more information about the parameters see `par`. +#' +#'@return Generates a file at the path specified via \code{fileout}. +#' +#'@seealso EOF, ProjectField, NAO +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2013-09 (F. Lienert, \email{flienert@@ic3.cat}) - Original code\cr +#'0.2 - 2015-03 (L. Batte, \email{lauriane.batte@@ic3.cat}) - Removed all\cr +#' normalization for sake of clarity. +#'1.0 - 2016-03 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Formatting to R CRAN +#'@examples +#'# See examples on Load() to understand the first lines in this example +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' leadtimemin = 1, leadtimemax = 4, output = 'lonlat', +#' latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 20, latmax = 80, +#' lonmin = -80, lonmax = 40) +#'# No example data is available over NAO region, so in this example we will +#'# tweak the available data. In a real use case, one can Load() the data over +#'# NAO region directly. +#'sampleData$lon[] <- c(40, 280, 340) +#'attr(sampleData$lon, 'first_lon') <- 280 +#'attr(sampleData$lon, 'last_lon') <- 40 +#'attr(sampleData$lon, 'data_across_gw') <- TRUE +#'sampleData$lat[] <- c(20, 80) +#'attr(sampleData$lat, 'first_lat') <- 20 +#'attr(sampleData$lat, 'last_lat') <- 80 +#' } +#'# Now ready to compute the EOFs and project on, for example, the first +#'# variability mode. +#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'nao <- NAO(ano$ano_exp, ano$ano_obs, sampleData$lon, sampleData$lat) +#'# Finally plot the nao index +#' \donttest{ +#'PlotBoxWhisker(nao$NAO_exp, nao$NAO_obs, "NAO index, DJF", "NAO index (PC1) TOS", +#' monini = 12, yearini = 1985, freq = 1, "Exp. A", "Obs. X") +#' } +#' +#'@importFrom grDevices dev.cur dev.new dev.off +#'@importFrom stats cor +#'@export +PlotBoxWhisker <- function(exp, obs, toptitle = '', ytitle = '', monini = 1, + yearini = 0, freq = 1, expname = "exp 1", + obsname = "obs 1", drawleg = TRUE, + fileout = "output_PlotBoxWhisker.ps", + 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("adj", "bty", "cex", "cex.axis", "cex.main", "col", "din", "fin", "lab", "las", "lty", "lwd", "mai", "mar", "mgp", "new", "pch", "ps") + 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 + } + + # Checking exp + if (is.numeric(exp)) { + if (is.null(dim(exp)) || length(dim(exp)) == 1) { + dim(exp) <- c(1, length(exp)) + } + } + if (!is.numeric(exp) || length(dim(exp)) != 2) { + stop("Parameter 'exp' must be a numeric vector or array of dimensions c(forecast horizons/start dates) or c(ensemble members, forecast horizons/start dates)") + } + + # Checking obs + if (is.numeric(obs)) { + if (is.null(dim(obs)) || length(dim(obs)) == 1) { + dim(obs) <- c(1, length(obs)) + } + } + if (!is.numeric(obs) || length(dim(obs)) != 2) { + stop("Parameter 'obs' must be a numeric vector or array of dimensions c(forecast horizons/start dates) or c(1, forecast horizons/start dates)") + } + + # Checking consistency in exp and obs + if (dim(exp)[2] != dim(obs)[2]) { + stop("'exp' and 'obs' must have data for the same amount of time steps.") + } + + if (!is.character(toptitle) || !is.character(ytitle)) { + stop("Parameters 'ytitle' and 'toptitle' must be character strings.") + } + + if (!is.numeric(monini)) { + stop("'monini' must be a month number, from 1 to 12.") + } + if (monini < 1 || monini > 12) { + stop("'monini' must be >= 1 and <= 12.") + } + + if (!is.numeric(yearini)) { + stop("'yearini' must be a month number, from 1 to 12.") + } + + if (!is.numeric(freq)) { + stop("'freq' must be a number <= 12.") + } + + if (!is.character(expname) || !is.character(obsname)) { + stop("'expname' and 'obsname' must be character strings.") + } + + if (!is.logical(drawleg)) { + stop("Parameter 'drawleg' must be either TRUE or FALSE.") + } + + if (!is.character(fileout) && !is.null(fileout)) { + stop("Parameter 'fileout' must be a character string.") + } + + ntimesteps <- dim(exp)[2] + lastyear <- (monini + (ntimesteps - 1) * 12 / freq - 1) %/% 12 + yearini + lastmonth <- (monini + (ntimesteps - 1) * 12 / freq - 1) %% 12 + 1 + # + # Define some plot parameters + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + labind <- seq(1, ntimesteps) + months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", + "Oct", "Nov", "Dec") + labyear <- ((labind - 1) * 12 / freq + monini - 1) %/% 12 + yearini + labmonth <- months[((labind - 1) * 12 / freq + monini - 1) %% 12 + 1] + for (jx in 1:length(labmonth)) { + y2o3dig <- paste("0", as.character(labyear[jx]), sep = "") + labmonth[jx] <- paste(labmonth[jx], "\nYr ", substr(y2o3dig, + nchar(y2o3dig) - 1, nchar(y2o3dig)), sep = "") + } + + # 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) + } + + # Load the user parameters + par(userArgs) + + ## Observed time series. + #pc.o <- ts(obs[1, ], deltat = 1, start = yr1, end = yr2) + pc.o <- obs[1, ] + ## Normalization of obs, forecast members. Fabian + ## Normalization of forecast should be according to ensemble + ## mean, to keep info on ensemble spread, no? Lauriane pc.o <- + ## pc.o/sd(pc.o) sd.fc <- apply(exp,c(1),sd) + ## exp <- exp/sd.fc mn.fc <- + ## apply(exp,2, mean) exp <- + ## exp/sd(mn.fc) Produce plot. + par(mar = c(5, 6, 4, 2)) + boxplot(exp, add = FALSE, main = toptitle, + ylab = "", xlab = "", col = "red", lwd = 2, t = "b", + axes = FALSE, cex.main = 2, ylim = c(-max(abs(c(exp, pc.o))), max(abs(c(exp, pc.o))))) + lines(1:ntimesteps, pc.o, lwd = 3, col = "blue") + abline(h = 0, lty = 1) + if (drawleg) { + legend("bottomleft", c(obsname, expname), lty = c(1, 1), lwd = c(3, + 3), pch = c(NA, NA), col = c("blue", "red"), horiz = FALSE, + bty = "n", inset = 0.05) + } + ##mtext(1, line = 3, text = tar, cex = 1.9) + mtext(3, line = -2, text = paste(" AC =", round(cor(pc.o, + apply(exp, c(2), mean)), 2)), cex = 1.9, adj = 0) + axis(2, cex.axis = 2) + mtext(2, line = 3, text = ytitle, cex = 1.9) + par(mgp = c(0, 4, 0)) + ##axis(1, c(1:ntimesteps), NA, cex.axis = 2) + axis(1, seq(1, ntimesteps, by = 1), labmonth, cex.axis = 2) + box() + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() +} + diff --git a/R/PlotClim.R b/R/PlotClim.R new file mode 100644 index 0000000..a002429 --- /dev/null +++ b/R/PlotClim.R @@ -0,0 +1,214 @@ +#'Plots Climatologies +#' +#'Plots climatologies as a function of the forecast time for any index output +#'from \code{Clim()} and organized in matrix with dimensions:\cr +#'c(nmod/nexp, nmemb/nparam, nltime) or c(nmod/nexp, nltime) for the +#'experiment data\cr +#'c(nobs, nmemb, nltime) or c(nobs, nltime) for the observational data +#' +#'@param exp_clim Matrix containing the experimental data with dimensions:\cr +#' c(nmod/nexp, nmemb/nparam, nltime) or c(nmod/nexp, nltime) +#'@param obs_clim Matrix containing the observational data (optional) with +#' dimensions:\cr +#' c(nobs, nmemb, nltime) or c(nobs, nltime) +#'@param toptitle Main title, optional. +#'@param ytitle Title of Y-axis, optional. +#'@param monini Starting month between 1 and 12. Default = 1. +#'@param freq 1 = yearly, 12 = monthly, 4 = seasonal, ... Default = 12. +#'@param limits c(lower limit, upper limit): limits of the Y-axis, optional. +#'@param listexp List of experiment names, optional. +#'@param listobs List of observational dataset names, optional. +#'@param biglab TRUE/FALSE for presentation/paper plot. Default = FALSE. +#'@param leg TRUE/FALSE to plot the legend or not. +#'@param sizetit Multiplicative factor to scale title size, optional. +#'@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 fileout Name of output file. Extensions allowed: eps/ps, jpeg, png, +#' pdf, bmp and tiff. \cr +#' Default = 'output_plotclim.eps'. +#'@param ... 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 fig font font.axis font.lab font.main font.sub lend +#' lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page pch plt +#' smo srt tck usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +#' For more information about the parameters see `par`. +#' +#'@keywords datagen +#'@author History:\cr +#'0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to CRAN +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#' \donttest{ +#'PlotClim(clim$clim_exp, clim$clim_obs, toptitle = paste('climatologies'), +#' ytitle = 'K', monini = 11, listexp = c('CMIP5 IC3'), +#' listobs = c('ERSST'), biglab = FALSE, fileout = 'tos_clim.eps') +#' } +#' +#'@importFrom grDevices dev.cur dev.new dev.off +#'@importFrom stats ts +#'@export +PlotClim <- function(exp_clim, obs_clim = NULL, toptitle = '', ytitle = '', + monini = 1, freq = 12, limits = NULL, + listexp = c('exp1', 'exp2', 'exp3'), + listobs = c('obs1', 'obs2', 'obs3'), biglab = FALSE, + leg = TRUE, sizetit = 1, fileout = 'output_plotclim.eps', + 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", "fin", "lab", "las", "lty", "lwd", "mai", "mgp", "new", "pin", "ps", "pty", "tcl") + 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 + } + + # + # Get some arguments + # ~~~~~~~~~~~~~~~~~~~~ + # + if (length(dim(exp_clim)) != 2 & length(dim(exp_clim)) != 3 ) { + stop("2 or 3 dim needed : c(nexp, nltime) or c(nexp, nmemb, nltime)") + } + if (length(dim(exp_clim)) < 3) { + exp_clim <- InsertDim(exp_clim, 2, 1) + } + nleadtime <- dim(exp_clim)[3] + nexp <- dim(exp_clim)[1] + if (is.null(obs_clim)) { + nobs <- 0 + } else { + nobs <- dim(obs_clim)[1] + if (length(dim(obs_clim)) != 2 & length(dim(obs_clim)) != 3 ) { + stop("2 or 3 dim needed : c(nobs, nltime) or c(nobs, nmemb, nltime)") + } + if (length(dim(obs_clim)) < 3) { + obs_clim <- InsertDim(obs_clim, 2, 1) + } + if (dim(obs_clim)[3] != nleadtime) { + stop("obs and exp must have same number of ltimes") + } + } + if (is.null(limits) == TRUE) { + ll <- min(min(exp_clim, na.rm = TRUE), min(obs_clim, na.rm = TRUE), na.rm = TRUE) + ul <- max(max(exp_clim, na.rm = TRUE), max(obs_clim, na.rm = TRUE), na.rm = TRUE) + if (biglab) { + ul <- ul + 0.3 * (ul - ll) + } else { + ul <- ul + 0.2 * (ul - ll) + } + } else { + ll <- limits[1] + ul <- limits[2] + } + lastyear <- (monini + (nleadtime - 1) * 12 / freq - 1) %/% 12 + lastmonth <- (monini + (nleadtime - 1) * 12 / freq - 1) %% 12 + 1 + # + # Define some plot parameters + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + if (biglab) { + labind <- seq(1, nleadtime, max(nleadtime %/% 5, 1)) + } else { + labind <- seq(1, nleadtime, max(nleadtime %/% 10, 1)) + } + months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", + "Oct", "Nov", "Dec") + labyear <- ((labind - 1) * 12 / freq + monini - 1) %/% 12 + labmonth <- months[((labind - 1) * 12 / freq + monini - 1) %% 12 + 1] + for (jx in 1:length(labmonth)) { + y2o3dig <- paste("0", as.character(labyear[jx]), sep = "") + labmonth[jx] <- paste(labmonth[jx], "\nYr ", substr(y2o3dig, + nchar(y2o3dig) - 1, nchar(y2o3dig)), sep = "") + } + empty_ts <- ts(start = c(0000, (monini - 1) %/% (12 / freq) + 1), + end = c(lastyear, (lastmonth - 1) %/% (12 / freq) + 1), + frequency = freq) + empty <- array(dim = length(empty_ts)) + color <- c("red1", "dodgerblue1", "green1", "orange1", "lightblue1", + "deeppink1", "mediumpurple1", "lightgoldenrod1", "olivedrab1", + "mediumorchid1") + type <- c(1, 3, 2, 4) + thickness <- c(1, 3, 1, 2) + # + # Define plot layout + # ~~~~~~~~~~~~~~~~~~~~ + # + + # 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) + } + + # Load the user parameters + par(userArgs) + + if (biglab) { + par(mai = c(1.25, 1.4, 0.5, 0), mgp = c(4, 2.5, 0)) + par(cex = 1.3, cex.lab = 2, cex.axis = 1.8) + cexmain <- 2.2 + legsize <- 1.5 + } else { + par(mai = c(1, 1.1, 0.5, 0), mgp = c(3, 1.8, 0)) + par(cex = 1.3, cex.lab = 1.5, cex.axis = 1.1) + cexmain <- 1.5 + legsize <- 1 + } + plot(empty, ylim = c(ll, ul), xlab = "Time (months)", ylab = ytitle, + main = toptitle, cex.main = cexmain * sizetit, axes = FALSE) + axis(1, at = labind, labels = labmonth) + axis(2) + box() + # + # Loops on experimental and observational data + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + for (jexp in 1:nexp) { + for (jmemb in 1:dim(exp_clim)[2]) { + par(new = TRUE) + plot(exp_clim[jexp, jmemb, ], type = "l", lty = 1, lwd = 2, + ylim = c(ll, ul), col = color[jexp], ylab = "", xlab = "", + axes = FALSE) + } + } + if (nobs > 0) { + for (jobs in 1:nobs) { + for (jmemb in 1:dim(obs_clim)[2]) { + par(new = TRUE) + plot(obs_clim[jobs, jmemb, ], lty = type[jobs], lwd = thickness[jobs], + type = "l", ylim = c(ll, ul), col = 1, ylab = "", xlab = "", + axes = FALSE) + } + } + if (leg) { + legend(1, ul, c(listexp[1:nexp], listobs[1:nobs]), + lty = c(array(1, dim = nexp), type[1:nobs]), + lwd = c(array(2, dim = nexp), thickness[1:nobs]), + col = c(color[1:nexp], array(1, dim = nobs)), cex = legsize) + } + } else { + if (leg) { + legend(1, ul, listexp[1:nexp], lty = 1, lwd = 2, col = color[1:nexp], + cex = legsize) + } + } + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() +} diff --git a/R/PlotEquiMap.R b/R/PlotEquiMap.R new file mode 100644 index 0000000..8f3fcb9 --- /dev/null +++ b/R/PlotEquiMap.R @@ -0,0 +1,874 @@ +#'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. This plot function is compatible with figure layouts if colour +#'bar is disabled. +#' +#'@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 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 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. +#'@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 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). +#'} +#' +#'@keywords dynamic +#'@author History:\cr +#' 0.1 - 2011-11 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#' 0.2 - 2013-04 (R. Saurral \email{ramiro.saurral@@ic3.cat}) - LabW\cr +#' 1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to R CRAN\cr +#' 1.1 - 2013-09 (C. Prodhomme, \email{chloe.prodhomme@@ic3.cat}) - add winds\cr +#' 1.2 - 2016-08 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Refactored and added features, +#' and adapted to new ColorBar. +#'@examples +#'# See examples on Load() to understand the first lines in this example +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' leadtimemin = 1, leadtimemax = 4, output = 'lonlat', +#' latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#'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, + contours = NULL, brks2 = NULL, contour_lwd = 0.5, + contour_color = 'black', contour_lty = 1, + 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, + 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 + } else if (filled.continents) { + continent_color <- gray(0.5) + } + + # 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 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.") + } + + # 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.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) + plot.window(xlim = range(lonb$x, finite = TRUE), ylim = range(latb$x, finite = TRUE), + xaxs = 'i', yaxs = 'i') + if (axelab) { + axis(2, at = ypos, labels = ylabs, cex.axis = cex_axes_labels, tcl = cex_axes_ticks, + mgp = c(0, spaceticklab + 0.2, 0)) + axis(1, at = xpos, labels = xlabs, cex.axis = cex_axes_labels, tcl = cex_axes_ticks, + mgp = c(0, spaceticklab + cex_axes_labels / 2 - 0.3, 0)) + } + 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)) { + 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, + col = contour_color) + } + + # + # 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 + # ~~~~~~~~~~~~~~~~~~~~~ + # + coast <- map(continents, interior = FALSE, wrap = TRUE, + fill = filled.continents, add = TRUE, plot = FALSE) + if (filled.continents) { + old_lwd <- par('lwd') + par(lwd = coast_width) + 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") + coastmap$STROKES$col[which(coastmap$STROKES$col != "blue")] <- continent_color + coastmap$STROKES$col[lakes] <- "white" + par(new = TRUE) + GEOmap::plotGEOmap(coastmap, PROJ = proj, border = coast_color, + add = TRUE, lwd = coast_width) + } else { + polygon(coast, col = continent_color, border = coast_color, lwd = coast_width) + } + par(lwd = old_lwd) + } else { + lines(coast, col = coast_color, lwd = coast_width) + } + 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)) + lattab <- InsertDim(latb$x, 1, length( lonb$x)) + 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)) +} diff --git a/R/PlotLayout.R b/R/PlotLayout.R new file mode 100644 index 0000000..b5239f2 --- /dev/null +++ b/R/PlotLayout.R @@ -0,0 +1,667 @@ +#'Arrange and Fill Multi-Pannel Layouts With Optional Colour Bar +#' +#'This function takes an array or list of arrays and loops over each of them +#'to plot all the sub-arrays they contain on an automatically generated +#'multi-pannel layout. A different plot function (not necessarily from +#'s2dverification) can be applied over each of the provided arrays. The input +#'dimensions of each of the functions have to be specified, either with the +#'names or the indices of the corresponding input dimensions. It is possible +#'to draw a common colour bar at any of the sides of the multi-pannel for all +#'the s2dverification plots that use a colour bar. Common plotting arguments +#'for all the arrays in 'var' can be specified via the '...' parameter, and +#'specific plotting arguments for each array can be fully adjusted via +#''special_args'. It is possible to draw titles for each of the figures, +#'layout rows, layout columns and for the whole figure. A number of parameters +#'is provided in order to adjust the position, size and colour of the +#'components. Blank cells can be forced to appear and later be filled in +#'manually with customized plots.\cr +#'This function pops up a blank new device and fills it in, so it cannot be +#'nested in complex layouts. +#' +#'@param fun Plot function (or name of the function) to be called on the +#' arrays provided in 'var'. If multiple arrays are provided in 'var', a +#' vector of as many function names (character strings!) can be provided in +#' 'fun', one for each array in 'var'. +#'@param plot_dims Numeric or character string vector with identifiers of the +#' input plot dimensions of the plot function specified in 'fun'. If +#' character labels are provided, names(dim(var)) or attr('dimensions', var) +#' will be checked to locate the dimensions. As many plots as +#' prod(dim(var)[-plot_dims]) will be generated. If multiple arrays are +#' provided in 'var', 'plot_dims' can be sent a list with a vector of plot +#' dimensions for each. If a single vector is provided, it will be used for +#' all the arrays in 'var'. +#'@param var Multi-dimensional array with at least the dimensions expected by +#' the specified plot function in 'fun'. The dimensions reqired by the +#' function must be specified in 'plot_dims'. The dimensions can be +#' disordered and will be reordered automatically. Dimensions can optionally +#' be labelled in order to refer to them with names in 'plot_dims'. All the +#' available plottable sub-arrays will be automatically plotted and arranged +#' in consecutive cells of an automatically arranged layout. A list of +#' multiple (super-)arrays can be specified. The process will be repeated for +#' each of them, by default applying the same plot function to all of them +#' or, if properly specified in 'fun', a different plot function will be +#' applied to each of them. NAs can be passed to the list: a NA will yield a +#' blank cell in the layout, which can be populated after +#' (see .SwitchToFigure). +#'@param \dots Parameters to be sent to the plotting function 'fun'. If +#' multiple arrays are provided in 'var' and multiple functions are provided +#' in 'fun', the parameters provided through \dots will be sent to all the +#' plot functions, as common parameters. To specify concrete arguments for +#' each of the plot functions see parameter 'special_args'. +#'@param special_args List of sub-lists, each sub-list having specific extra +#' arguments for each of the plot functions provided in 'fun'. If you want to +#' fix a different value for each plot in the layout you can do so by +#' a) splitting your array into a list of sub-arrays (each with the data for +#' one plot) and providing it as parameter 'var', +#' b) providing a list of named sub-lists in 'special_args', where the names +#' of each sub-list match the names of the parameters to be adjusted, and +#' each value in a sub-list contains the value of the corresponding parameter. +#'@param nrow Numeric value to force the number of rows in the automatically +#' generated layout. If higher than the required, this will yield blank cells +#' in the layout (which can then be populated). If lower than the required +#' the function will stop. By default it is configured to arrange the layout +#' in a shape as square as possible. Blank cells can be manually populated +#' after with customized plots (see SwitchTofigure). +#'@param ncol Numeric value to force the number of columns in the +#' automatically generated layout. If higher than the required, this will +#' yield blank cells in the layout (which can then be populated). If lower +#' than the required the function will stop. By default it is configured to +#' arrange the layout in a shape as square as possible. Blank cells can be +#' manually populated after with customized plots (see SwitchTofigure). +#'@param toptitle Topt title for the multi-pannel. Blank by default. +#'@param row_titles Character string vector with titles for each of the rows +#' in the layout. Blank by default. +#'@param col_titles Character string vector with titles for each of the +#' columns in the layout. Blank by default. +#'@param bar_scale Scale factor for the common colour bar. Takes 1 by default. +#'@param title_scale Scale factor for the multi-pannel title. Takes 1 by +#' default. +#'@param title_margin_scale Scale factor for the margins surrounding the top +#' title. Takes 1 by default. +#'@param title_left_shift_scale When plotting row titles, a shift is added +#' to the horizontal positioning of the top title in order to center it to +#' the region of the figures (without taking row titles into account). This +#' shift can be reduced. A value of 0 will remove the shift completely, +#' centering the title to the total width of the device. This parameter will +#' be disregarded if no 'row_titles' are provided. +#'@param subtitle_scale Scale factor for the row titles and column titles +#' (specified in 'row_titles' and 'col_titles'). Takes 1 by default. +#'@param subtitle_margin_scale Scale factor for the margins surrounding the +#' subtitles. Takes 1 by default. +#'@param units Title at the top of the colour bar, most commonly the units of +#' the variable provided in parameter 'var'. +#'@param brks,cols,bar_limits,triangle_ends Usually only providing 'brks' is +#' enough to generate the desired colour bar. These parameters allow to +#' define n breaks that define n - 1 intervals to classify each of the values +#' in 'var'. The corresponding grid cell of a given value in 'var' will be +#' coloured in function of the interval it belongs to. These parameters are +#' sent to \code{ColorBar()} to generate the breaks and colours. Additional +#' colours for values beyond the limits of the colour bar are also generated +#' and applied to the plot if 'bar_limits' or 'brks' and 'triangle_ends' are +#' properly provided to do so. See ?ColorBar for a full explanation. +#'@param col_inf,col_sup Colour identifiers to colour the values in 'var' that +#' go beyond the extremes of the colour bar and to colour NA values, +#' respectively. 'colNA' takes 'white' by default. 'col_inf' and 'col_sup' +#' will take the value of 'colNA' if not specified. See ?ColorBar for a full +#' explanation on 'col_inf' and 'col_sup'. +#'@param color_fun,subsampleg,bar_extra_labels,draw_bar_ticks,draw_separators,triangle_ends_scale,bar_label_digits,bar_label_scale,units_scale,bar_tick_scale,bar_extra_margin Set of parameters to control the visual aspect of the drawn colour bar. See ?ColorBar for a full explanation. +#'@param drawleg Where to draw the common colour bar. Can take values TRUE, +#' FALSE or:\cr +#' 'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr +#' 'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr +#' 'right', 'r', 'R', 'east', 'e', 'E'\cr +#' 'left', 'l', 'L', 'west', 'w', 'W' +#'@param titles Character string vector with titles for each of the figures in +#' the multi-pannel, from top-left to bottom-right. Blank by default. +#'@param bar_left_shift_scale When plotting row titles, a shift is added to +#' the horizontal positioning of the colour bar in order to center it to the +#' region of the figures (without taking row titles into account). This shift +#' can be reduced. A value of 0 will remove the shift completely, centering +#' the colour bar to the total width of the device. This parameter will be +#' disregarded if no 'row_titles' are provided. +#'@param extra_margin Extra margins to be added around the layout, in the +#' format c(y1, x1, y2, x2). The units are margin lines. Takes rep(0, 4) +#' by default. +#'@param fileout File where to save the plot. If not specified (default) a +#' graphics device will pop up. Extensions allowed: eps/ps, jpeg, png, pdf, +#' bmp and tiff. +#'@param width Width in inches of the multi-pannel. 7 by default, or 11 if +#' 'fielout' has been specified. +#'@param height Height in inches of the multi-pannel. 7 by default, or 11 if +#' 'fileout' has been specified. +#'@param size_units Units of the size of the device (file or window) to plot +#' in. Inches ('in') by default. See ?Devices and the creator function of +#' the corresponding device. +#'@param res Resolution of the device (file or window) to plot in. See +#' ?Devices and the creator function of the corresponding device. +#'@param close_device Whether to close the graphics device after plotting +#' the layout and a 'fileout' has been specified. This is useful to avoid +#' closing the device when saving the layout into a file and willing to add +#' extra elements or figures. Takes TRUE by default. Disregarded if no +#' 'fileout' has been specified. +#' +#'@return +#'\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). +#'} +#'\item{layout_matrix}{ +#' Underlying matrix of the layout. Useful to later set any of the layout +#' cells as current figure to add plot elements. See .SwitchToFigure. +#'} +#' +#'@keywords dynamic +#'@author History:\cr +#' 0.1 - 2016-08 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Original code +#'@examples +#'# See examples on Load() to understand the first lines in this example +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' leadtimemin = 1, leadtimemax = 4, output = 'lonlat', +#' latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#'PlotLayout(PlotEquiMap, c('lat', 'lon'), sampleData$mod[1, , 1, 1, , ], +#' sampleData$lon, sampleData$lat, +#' toptitle = 'Predicted tos for Nov 1960 from 1st Nov', +#' titles = paste('Member', 1:15)) +#' +#'@importFrom grDevices dev.cur dev.new dev.off +#'@export +PlotLayout <- function(fun, plot_dims, var, ..., special_args = NULL, + nrow = NULL, ncol = NULL, toptitle = NULL, + row_titles = NULL, col_titles = NULL, bar_scale = 1, + title_scale = 1, title_margin_scale = 1, + title_left_shift_scale = 1, + subtitle_scale = 1, subtitle_margin_scale = 1, + brks = NULL, cols = NULL, drawleg = 'S', titles = NULL, + subsampleg = NULL, bar_limits = NULL, + triangle_ends = NULL, col_inf = NULL, col_sup = NULL, + color_fun = clim.colors, + draw_bar_ticks = TRUE, draw_separators = FALSE, + triangle_ends_scale = 1, bar_extra_labels = NULL, + units = NULL, units_scale = 1, bar_label_scale = 1, + bar_tick_scale = 1, bar_extra_margin = rep(0, 4), + bar_left_shift_scale = 1, bar_label_digits = 4, + extra_margin = rep(0, 4), + fileout = NULL, width = NULL, height = NULL, + size_units = 'in', res = 100, close_device = TRUE) { + # If there is any filenames to store the graphics, process them + # to select the right device + if (!is.null(fileout)) { + deviceInfo <- .SelectDevice(fileout = fileout, width = width, height = height, units = size_units, res = res) + saveToFile <- deviceInfo$fun + fileout <- deviceInfo$files + } + + is_single_na <- function(x) ifelse(length(x) > 1, FALSE, is.na(x)) + # Check var + if (is.array(var) || (is_single_na(var))) { + var <- list(var) + } else if (is.list(var)) { + if (!all(sapply(var, is.array) | sapply(var, is_single_na))) { + stop("Parameter 'var' must be an array or a list of arrays (or NA values).") + } + } else { + stop("Parameter 'var' must be an array or a list of arrays.") + } + + # Check fun + if (length(fun) == 1) { + if (is.function(fun)) { + fun <- as.character(substitute(fun)) + } + if (is.character(fun)) { + fun <- rep(fun, length(var)) + } + } + if (!is.character(fun) || (length(fun) != length(var))) { + stop("Parameter 'fun' must be a single function or a vector of function names, one for each array provided in parameter 'var'.") + } + + # Check special_args + if (!is.null(special_args)) { + if (!is.list(special_args) || any(!sapply(special_args, is.list))) { + stop("Parameter 'special_args' must be a list of lists.") + } else if (length(special_args) != length(var)) { + stop("Parameter 'special_args' must contain a list of special arguments for each array provided in 'var'.") + } + } + + # Check plot_dims + if (is.character(plot_dims) || is.numeric(plot_dims)) { + plot_dims <- replicate(length(var), plot_dims, simplify = FALSE) + } + if (!is.list(plot_dims) || !all(sapply(plot_dims, is.character) | sapply(plot_dims, is.numeric)) || + (length(plot_dims) != length(var))) { + stop("Parameter 'plot_dims' must contain a single numeric or character vector with dimension identifiers or a vector for each array provided in parameter 'var'.") + } + + # Check nrow + if (!is.null(nrow)) { + if (!is.numeric(nrow)) { + stop("Parameter 'nrow' must be numeric or NULL.") + } + nrow <- round(nrow) + } + + # Check ncol + if (!is.null(ncol)) { + if (!is.numeric(ncol)) { + stop("Parameter 'ncol' must be numeric or NULL.") + } + ncol <- round(ncol) + } + + # Check toptitle + if (is.null(toptitle) || is.na(toptitle)) { + toptitle <- '' + } + if (!is.character(toptitle)) { + stop("Parameter 'toptitle' must be a character string.") + } + + # Check row_titles + if (!is.null(row_titles)) { + if (!is.character(row_titles)) { + stop("Parameter 'row_titles' must be a vector of character strings.") + } + } + + # Check col_titles + if (!is.null(row_titles)) { + if (!is.character(row_titles)) { + stop("Parameter 'row_titles' must be a vector of character strings.") + } + } + + # Check drawleg + if (is.character(drawleg)) { + if (drawleg %in% c('up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N')) { + drawleg <- 'N' + } else if (drawleg %in% c('down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S')) { + drawleg <- 'S' + } else if (drawleg %in% c('right', 'r', 'R', 'east', 'e', 'E')) { + drawleg <- 'E' + } else if (drawleg %in% c('left', 'l', 'L', 'west', 'w', 'W')) { + drawleg <- 'W' + } else { + stop("Parameter 'drawleg' must be either TRUE, FALSE or a valid identifier of a position (see ?PlotMultiMap).") + } + } else if (!is.logical(drawleg)) { + stop("Parameter 'drawleg' must be either TRUE, FALSE or a valid identifier of a position (see ?PlotMultiMap).") + } + if (drawleg != FALSE && all(sapply(var, is_single_na)) && + (is.null(brks) || length(brks) < 2)) { + stop("Either data arrays in 'var' or breaks in 'brks' must be provided if 'drawleg' is requested.") + } + + # Check the rest of parameters (unless the user simply wants to build an empty layout) + var_limits <- NULL + if (!all(sapply(var, is_single_na))) { + var_limits <- c(min(unlist(var), na.rm = TRUE), max(unlist(var), na.rm = TRUE)) + if ((any(is.infinite(var_limits)) || var_limits[1] == var_limits[2])) { + stop("Arrays in parameter 'var' must contain at least 2 different values.") + } + } + colorbar <- ColorBar(brks, cols, FALSE, subsampleg, bar_limits, + var_limits, triangle_ends, col_inf, col_sup, color_fun, + plot = FALSE, draw_bar_ticks, + draw_separators, triangle_ends_scale, bar_extra_labels, + units, units_scale, bar_label_scale, bar_tick_scale, + bar_extra_margin, bar_label_digits) + + # Check bar_scale + if (!is.numeric(bar_scale)) { + stop("Parameter 'bar_scale' must be numeric.") + } + + # Check bar_left_shift_scale + if (!is.numeric(bar_left_shift_scale)) { + stop("Parameter 'bar_left_shift_scale' must be numeric.") + } + + # Check title_scale + if (!is.numeric(title_scale)) { + stop("Parameter 'title_scale' must be numeric.") + } + + # Check title_margin_scale + if (!is.numeric(title_margin_scale)) { + stop("Parameter 'title_margin_scale' must be numeric.") + } + + # Check title_left_shift_scale + if (!is.numeric(title_left_shift_scale)) { + stop("Parameter 'title_left_shift_scale' must be numeric.") + } + + # Check subtitle_scale + if (!is.numeric(subtitle_scale)) { + stop("Parameter 'subtite_scale' must be numeric.") + } + + # Check subtitle_margin_scale + if (!is.numeric(subtitle_margin_scale)) { + stop("Parameter 'subtite_margin_scale' must be numeric.") + } + + # Check titles + if (!all(sapply(titles, is.character))) { + stop("Parameter 'titles' must be a vector of character strings.") + } + + # Check extra_margin + if (!is.numeric(extra_margin) || length(extra_margin) != 4) { + stop("Parameter 'extra_margin' must be a numeric vector with 4 elements.") + } + + # Check width + if (is.null(width)) { + if (is.null(fileout)) { + width <- 7 + } else { + width <- 11 + } + } + if (!is.numeric(width)) { + stop("Parameter 'width' must be numeric.") + } + + # Check height + if (is.null(height)) { + if (is.null(fileout)) { + height <- 7 + } else { + height <- 8 + } + } + if (!is.numeric(height)) { + stop("Parameter 'height' must be numeric.") + } + + # Check close_device + if (!is.logical(close_device)) { + stop("Parameter 'close_device' must be logical.") + } + + # Count the total number of maps and reorder each array of maps to have the lat and lon dimensions at the end. + n_plots <- 0 + plot_array_i <- 1 + for (plot_array in var) { + if (is_single_na(plot_array)) { + n_plots <- n_plots + 1 + } else { + dim_ids <- plot_dims[[plot_array_i]] + if (is.character(dim_ids)) { + dimnames <- NULL + if (!is.null(names(dim(plot_array)))) { + dimnames <- names(dim(plot_array)) + } else if (!is.null(attr(plot_array, 'dimensions'))) { + dimnames <- attr(plot_array, 'dimensions') + } + if (!is.null(dimnames)) { + if (any(!sapply(dim_ids, `%in%`, dimnames))) { + stop("All arrays provided in parameter 'var' must have all the dimensions in 'plot_dims'.") + } + dim_ids <- sapply(dim_ids, function(x) which(dimnames == x)[1]) + var[[plot_array_i]] <- .aperm2(var[[plot_array_i]], c((1:length(dim(plot_array)))[-dim_ids], dim_ids)) + } else { + .warning(paste0("Assuming the ", plot_array_i, "th array provided in 'var' has 'plot_dims' as last dimensions (right-most).")) + dims <- tail(c(rep(1, length(dim_ids)), dim(plot_array)), length(dim_ids)) + dim_ids <- tail(1:length(dim(plot_array)), length(dim_ids)) + if (length(dim(var[[plot_array_i]])) < length(dims)) { + dim(var[[plot_array_i]]) <- dims + } + } + } else if (any(dim_ids > length(dim(plot_array)))) { + stop("Parameter 'plot_dims' contains dimension identifiers out of range.") + } + n_plots <- n_plots + prod(dim(plot_array)[-dim_ids]) + #n_plots <- n_plots + prod(head(c(rep(1, length(dim_ids)), dim(plot_array)), length(dim(plot_array)))) + if (length(dim(var[[plot_array_i]])) == length(dim_ids)) { + dim(var[[plot_array_i]]) <- c(1, dim(var[[plot_array_i]])) + dim_ids <- dim_ids + 1 + } + plot_dims[[plot_array_i]] <- dim_ids + } + plot_array_i <- plot_array_i + 1 + } + if (is.null(nrow) && is.null(ncol)) { + ncol <- ceiling(sqrt(n_plots)) + nrow <- ceiling(n_plots/ncol) + } else if (is.null(ncol)) { + ncol <- ceiling(n_plots/nrow) + } else if (is.null(nrow)) { + nrow <- ceiling(n_plots/ncol) + } else if (nrow * ncol < n_plots) { + stop("There are more arrays to plot in 'var' than cells defined by 'nrow' x 'ncol'.") + } + + if (is.logical(drawleg) && drawleg) { + if (nrow > ncol) { + drawleg <- 'S' + } else { + drawleg <- 'E' + } + } + vertical <- drawleg %in% c('E', 'W') + + # 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) + } else if (prod(par('mfrow')) > 1) { + dev.new(units = units, res = res, width = width, height = height) + } + + # Take size of device and set up layout: + # --------------------------------------------- + # |0000000000000000000000000000000000000000000| + # |0000000000000000 TOP TITLE 0000000000000000| + # |0000000000000000000000000000000000000000000| + # |-------------------------------------------| + # |00000|0000000000000000000000000000000000000| + # |00000|000000000000 ROW TITLES 0000000000000| + # |00000|0000000000000000000000000000000000000| + # |00000|-------------------------------------| + # |0 0|222222222222222222|333333333333333333| + # |0 C 0|222222222222222222|333333333333333333| + # |0 O 0|222222222222222222|333333333333333333| + # |0 L 0|2222 FIGURE 1 2222|3333 FIGURE 2 3333| + # |0 0|222222222222222222|333333333333333333| + # |0 T 0|222222222222222222|333333333333333333| + # |0 I 0|222222222222222222|333333333333333333| + # |0 T 0|-------------------------------------| + # |0 L 0|444444444444444444|555555555555555555| + # |0 S 0|444444444444444444|555555555555555555| + # |0 0|444444444444444444|555555555555555555| + # |00000|4444 FIGURE 3 4444|5555 FIGURE 4 5555| + # |00000|444444444444444444|555555555555555555| + # |00000|444444444444444444|555555555555555555| + # |00000|444444444444444444|555555555555555555| + # |-------------------------------------------| + # |1111111111111111111111111111111111111111111| + # |1111111111111111 COLOR BAR 1111111111111111| + # |1111111111111111111111111111111111111111111| + # --------------------------------------------- + device_size <- par('din') + device_size[1] <- device_size[1] - sum(extra_margin[c(2, 4)]) + device_size[2] <- device_size[2] - sum(extra_margin[c(1, 3)]) + cs <- char_size <- par('csi') + title_cex <- 2.5 * title_scale + title_margin <- 0.5 * title_cex * title_margin_scale + subtitle_cex <- 1.5 * subtitle_scale + subtitle_margin <- 0.5 * sqrt(nrow * ncol) * subtitle_cex * subtitle_margin_scale + mat_layout <- 1:(nrow * ncol) + ifelse(drawleg != FALSE, 1, 0) + mat_layout <- matrix(mat_layout, nrow, ncol, byrow = TRUE) + fsu <- figure_size_units <- 10 # unitless + widths <- rep(fsu, ncol) + heights <- rep(fsu, nrow) + n_figures <- nrow * ncol + if (length(row_titles) > 0) { + mat_layout <- cbind(rep(0, dim(mat_layout)[1]), mat_layout) + widths <- c(((subtitle_cex + subtitle_margin / 2) * cs / device_size[1]) * ncol * fsu, widths) + } + if (length(col_titles) > 0) { + mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout) + heights <- c(((subtitle_cex + subtitle_margin) * cs / device_size[2]) * nrow * fsu, heights) + } + if (drawleg != FALSE) { + if (drawleg == 'N') { + mat_layout <- rbind(rep(1, dim(mat_layout)[2]), mat_layout) + heights <- c(round(bar_scale * 2 * nrow), heights) + } else if (drawleg == 'S') { + mat_layout <- rbind(mat_layout, rep(1, dim(mat_layout)[2])) + heights <- c(heights, round(bar_scale * 2 * nrow)) + } else if (drawleg == 'W') { + mat_layout <- cbind(rep(1, dim(mat_layout)[1]), mat_layout) + widths <- c(round(bar_scale * 3 * ncol), widths) + } else if (drawleg == 'E') { + mat_layout <- cbind(mat_layout, rep(1, dim(mat_layout)[1])) + widths <- c(widths, round(bar_scale * 3 * ncol)) + } + n_figures <- n_figures + 1 + } + if (toptitle != '') { + mat_layout <- rbind(rep(0, dim(mat_layout)[2]), mat_layout) + heights <- c(((title_cex + title_margin) * cs / device_size[2]) * nrow * fsu, heights) + } + par(oma = extra_margin) + layout(mat_layout, widths, heights) + # Draw the color bar + if (drawleg != FALSE) { + if (length(row_titles) > 0) { + bar_extra_margin[2] <- bar_extra_margin[2] + (subtitle_cex + subtitle_margin / 2) * + bar_left_shift_scale + } + ColorBar(colorbar$brks, colorbar$cols, vertical, subsampleg, + bar_limits, var_limits, + triangle_ends = triangle_ends, col_inf = colorbar$col_inf, + col_sup = colorbar$col_sup, color_fun, plot = TRUE, draw_bar_ticks, + draw_separators, triangle_ends_scale, bar_extra_labels, + units, units_scale, bar_label_scale, bar_tick_scale, + bar_extra_margin, bar_label_digits) + } + + # Draw titles + if (toptitle != '' || length(col_titles) > 0 || length(row_titles) > 0) { + plot(0, type = 'n', ann = FALSE, axes = FALSE, xaxs = 'i', yaxs = 'i', + xlim = c(0, 1), ylim = c(0, 1)) + width_lines <- par('fin')[1] / par('csi') + plot_lines <- par('pin')[1] / par('csi') + plot_range <- par('xaxp')[2] - par('xaxp')[1] + size_units_per_line <- plot_range / plot_lines + if (toptitle != '') { + title_x_center <- par('xaxp')[1] - par('mar')[2] * size_units_per_line + + ncol * width_lines * size_units_per_line / 2 + if (length(row_titles) > 0) { + title_x_center <- title_x_center - (1 - title_left_shift_scale) * + (subtitle_cex + subtitle_margin) / 2 * size_units_per_line + } + title_y_center <- par('mar')[3] + (title_margin + title_cex) / 2 + if (length(col_titles > 0)) { + title_y_center <- title_y_center + (subtitle_margin + subtitle_cex) + } + mtext(toptitle, cex = title_cex, line = title_y_center, at = title_x_center, + padj = 0.5) + } + if (length(col_titles) > 0) { + t_x_center <- par('xaxp')[1] - par('mar')[2] * size_units_per_line + for (t in 1:ncol) { + mtext(col_titles[t], cex = subtitle_cex, + line = par('mar')[3] + (subtitle_margin + subtitle_cex) / 2, + at = t_x_center + (t - 0.5) * width_lines * size_units_per_line, + padj = 0.5) + } + } + height_lines <- par('fin')[2] / par('csi') + plot_lines <- par('pin')[2] / par('csi') + plot_range <- par('yaxp')[2] - par('yaxp')[1] + size_units_per_line <- plot_range / plot_lines + if (length(row_titles) > 0) { + t_y_center <- par('yaxp')[1] - par('mar')[1] * size_units_per_line + for (t in 1:nrow) { + mtext(row_titles[t], cex = subtitle_cex, + line = par('mar')[2] + (subtitle_margin + subtitle_cex) / 2, + at = t_y_center - (t - 1.5) * height_lines * size_units_per_line, + padj = 0.5, side = 2) + } + } + par(new = TRUE) + } + + array_number <- 1 + plot_number <- 1 + # For each array provided in var + lapply(var, function(x) { + if (is_single_na(x)) { + if (!all(sapply(var[array_number:length(var)], is_single_na))) { + plot.new() + par(new = FALSE) + } + plot_number <<- plot_number + 1 + } else { + if (is.character(plot_dims[[array_number]])) { + plot_dim_indices <- which(names(dim(x)) %in% plot_dims[[array_number]]) + } else { + plot_dim_indices <- plot_dims[[array_number]] + } + # For each of the arrays provided in that array + apply(x, (1:length(dim(x)))[-plot_dim_indices], + function(y) { + # Do the plot + fun_args <- c(list(y, toptitle = titles[plot_number]), list(...), + special_args[[array_number]]) + funct <- fun[[array_number]] + if (fun[[array_number]] %in% c('PlotEquiMap', 'PlotStereoMap', 'PlotSection')) { + fun_args <- c(fun_args, list(brks = colorbar$brks, cols = colorbar$cols, + col_inf = colorbar$col_inf, + col_sup = colorbar$col_sup, + drawleg = FALSE)) + } + do.call(fun[[array_number]], fun_args) + plot_number <<- plot_number + 1 + }) + } + array_number <<- array_number + 1 + }) + + # If the graphic was saved to file, close the connection with the device + if (!is.null(fileout) && close_device) dev.off() + + invisible(list(brks = colorbar$brks, cols = colorbar$cols, + col_inf = colorbar$col_inf, col_sup = colorbar$col_sup, + layout_matrix = mat_layout)) +} diff --git a/R/PlotMatrix.R b/R/PlotMatrix.R new file mode 100644 index 0000000..8c830d7 --- /dev/null +++ b/R/PlotMatrix.R @@ -0,0 +1,227 @@ +#'Function to convert any numerical table to a grid of coloured squares. +#' +#'This function converts a numerical data matrix into a coloured +#'grid. It is useful for a slide or article to present tabular results as +#'colors instead of numbers. +#' +#'@param var A numerical matrix containing the values to be displayed in a +#' colored image. +#'@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 color 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 title.color A string of valid color identifier to decide the title +#' color. Set "royalblue4" as default. +#'@param xtitle A string of title of the x-axis. Set NULL as default. +#'@param ytitle A string of title of the y-axis. Set NULL as default. +#'@param xlabels A vector of labels of the x-axis. The length must be +#' length of the column of parameter 'var'. Set the sequence from 1 to the +#' length of the column of parameter 'var' as default. +#'@param xvert A logical value to decide whether to place x-axis labels +#' vertically. Set FALSE as default, which keeps the labels horizontally. +#'@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 line An integer specifying the distance between the title of the +#' x-axis and the x-axis. Set 3 as default. Adjust if the x-axis labels +#' are long. +#'@param figure.width A positive number as a ratio adjusting the width of the +#' grids. Set 1 as default. +#'@param legend A logical value to decide to draw the grid color legend or not. +#' Set TRUE as default. +#'@param legend.width A number between 0 and 0.5 to adjust the legend width. +#' Set 0.15 as default. +#'@param xlab_dist A number specifying the distance between the x labels and +#' the x axis. If not specified, it equals to -1 - (nrow(var) / 10 - 1). +#'@param ylab_dist A number specifying the distance between the y labels and +#' the y axis. If not specified, it equals to 0.5 - ncol(var) / 10. +#'@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. +#' +#'@examples +#'#Example with random data +#' PlotMatrix(var = matrix(rnorm(n = 120, mean = 0.3), 10, 12), +#' 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), +#' toptitle = "Mean Absolute Error", +#' xtitle = "Forecast time (month)", ytitle = "Start date", +#' xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", +#' "Aug", "Sep", "Oct", "Nov", "Dec")) +#'@importFrom grDevices dev.new dev.off dev.cur +#'@export +PlotMatrix <- function(var, brks = NULL, cols = NULL, + toptitle = NULL, title.color = "royalblue4", + xtitle = NULL, ytitle = NULL, xlabels = NULL, xvert = FALSE, + ylabels = NULL, line = 3, figure.width = 1, legend = TRUE, + legend.width = 0.15, xlab_dist = NULL, ylab_dist = NULL, + fileout = NULL, size_units = 'px', res = 100, ...) { + + # Check variables: + if (!is.matrix(var)) + stop("Input values are not a matrix") + if (!is.numeric(var)) + stop("Input values are not always numbers") + + # Build: brks, cols + colorbar <- ColorBar(brks = brks, cols = cols, vertical = FALSE, + plot = FALSE, ...) + brks <- colorbar$brks + cols <- colorbar$cols + + n.cols <- length(cols) ## number of colours + n.brks <- length(brks) ## number of intervals + + if (n.brks != n.cols + 1) + stop("There must be one break more than the number of colors") + ncols <- ncol(var) ## number of columns of the image + nrows <- nrow(var) ## number of rows of the image + if (ncols < 2) + stop("Matrix must have at least two columns") + if (nrows < 2) + stop("Matrix must have at least two rows") + if (!is.null(xlabels) && length(xlabels) != ncols) + stop(paste0("The number of x labels must be equal to the number of ", + "columns of the data matrix")) + if (!is.null(ylabels) && length(ylabels) != nrows) + stop(paste0("The number of y labels must be equal to the number of ", + "rows of the data matrix")) + if (!is.numeric(figure.width) || figure.width < 0) + stop("figure.width must be a positive number") + if (!is.numeric(legend.width) || legend.width < 0 || legend.width > 0.5) + stop("legend.width must be a number from 0 to 0.5") + + + # 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 = 80 * ncols * figure.width, + height = 80 * nrows, + 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(fileout)) { + + # Draw empty plot: + par(mar = c(4, 4, 1, 0), fig = c(0.1, 1 - legend.width, 0.1, 0.9)) + plot(1, 1, type = "n", xaxt = "n", yaxt = "n", ylim = c(0.5, nrows + 0.5), + xlim = c(-0.5, ncols - 1 + 0.5), ann = F, bty = "n") + + # Add axes titles: + label.size <- 1.2 * (max(ncols, nrows) / 10) ^ 0.5 + mtext(side = 1, text = xtitle, line = line, cex = label.size, font = 3) + mtext(side = 2, text = ytitle, line = 3, cex = label.size, font = 3) + + # Add plot title: + if (is.null(title.color)) title.color <- "royalblue4" + mtext(side = 3, text = toptitle, cex = 1.75 * (nrows / 10) ^ 0.7, + col = title.color) + + # Add axis labels: + axis.size <- (max(ncols, nrows) / 10) ^ 0.3 + if (is.null(xlabels)) xlabels = 1:ncols + if (is.null(ylabels)) ylabels = 1:nrows + + if(is.null(xlab_dist)) { ## Add x axis labels + axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, + cex.axis = axis.size, tck = 0, lwd = 0, line = - 1 - (nrows / 10 - 1)) + } else { + axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, + cex.axis = axis.size, tck = 0, lwd = 0, line = xlab_dist) + } + if(is.null(ylab_dist)) { ## Add y axis labels + axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels), + cex.axis = axis.size, tck = 0, lwd = 0, line = 0.5 - ncols / 10) + } else { + axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels), + cex.axis = axis.size, tck = 0, lwd = 0, line = ylab_dist) + } + + } else { + + # Draw empty plot: + par(mar = c(4, 4, 1, 0), fig = c(0.1, 1 - legend.width, 0.1, 0.9)) + plot(1, 1, type = "n", xaxt = "n", yaxt = "n", ylim = c(0.5, nrows + 0.5), + xlim = c(-0.5, ncols - 1 + 0.5), ann = F, bty = "n") + + # Add axes titles: + label.size <- 1.2 # * (max(ncols, nrows) / 10) ^ 0.5 + mtext(side = 1, text = xtitle, line = line, cex = label.size, font = 3) + mtext(side = 2, text = ytitle, line = 3, cex = label.size, font = 3) + + # Add plot title: + if (is.null(title.color)) title.color <- "royalblue4" + mtext(side = 3, text = toptitle, cex = 1.5, #* (nrows / 10) ^ 0.7, + col = title.color) + + # Add axis labels: + axis.size <- 1 #(max(ncols, nrows) / 10) ^ 0.3 + if (is.null(xlabels)) xlabels = 1:ncols + if (is.null(ylabels)) ylabels = 1:nrows + + if(is.null(xlab_dist)){ ## Add x axis labels + axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, + cex.axis = axis.size, tck = 0, lwd = 0, line = - 1 - (nrows / 10 - 1)) + } else { + axis(1, at = seq(0, ncols - 1), las = ifelse(xvert, 2, 1), labels = xlabels, + cex.axis = axis.size, tck = 0, lwd = 0, line = xlab_dist) + } + if(is.null(ylab_dist)){ ## Add y axis labels + axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels), + cex.axis = axis.size, tck = 0, lwd = 0, line = 0.5 - ncols / 10) + } else { + axis(2, at = seq(1, nrows), las = 1, labels = rev(ylabels), + cex.axis = axis.size, tck = 0, lwd = 0, line = ylab_dist) + } + + } + + # Create an array of colors instead of numbers (it starts all gray): + array.colors <- array("gray", c(nrows, ncols)) + for (int in n.cols:1) array.colors[var <= brks[int + 1]] <- cols[int] + + # fill with colors the cells in the figure: + for (p in 1:nrows) { + for (l in 0:(ncols - 1)) { + polygon(c(0.5 + l - 1, 0.5 + l - 1, 1.5 + l - 1, 1.5 + l - 1), + c(-0.5 + nrows + 1 - p, 0.5 + nrows + 1 - p, + 0.5 + nrows + 1 - p, -0.5 + nrows + 1 - p), + col = array.colors[p, 1 + l], border = "black") + } + } + + # Draw color legend: + if (legend) { + par(fig = c(1 - legend.width - 0.01, + 1 - legend.width + legend.width * min(1, 10 / ncols), + 0.3, 0.8), new = TRUE) + #legend.label.size <- (max(ncols, nrows) / 10) ^ 0.4 + ColorBar(brks = brks, cols = cols, vertical = TRUE, ...) + } + + # 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)) + +} diff --git a/R/PlotSection.R b/R/PlotSection.R new file mode 100644 index 0000000..46a1e70 --- /dev/null +++ b/R/PlotSection.R @@ -0,0 +1,172 @@ +#'Plots A Vertical Section +#' +#'Plot a (longitude,depth) or (latitude,depth) section. +#' +#'@param var Matrix to plot with (longitude/latitude, depth) dimensions. +#'@param horiz Array of longitudes or latitudes. +#'@param depth Array of depths. +#'@param toptitle Title, optional. +#'@param sizetit Multiplicative factor to increase title size, optional. +#'@param units Units, optional. +#'@param brks Colour levels, optional. +#'@param cols List of colours, optional. +#'@param axelab TRUE/FALSE, label the axis. Default = TRUE. +#'@param intydep Interval between depth ticks on y-axis. Default: 200m. +#'@param intxhoriz Interval between longitude/latitude ticks on x-axis.\cr +#' Default: 20deg. +#'@param drawleg Draw colorbar. Default: TRUE. +#'@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 fileout Name of output file. Extensions allowed: eps/ps, jpeg, png, +#' pdf, bmp and tiff. \cr +#' Default = NULL +#'@param ... Arguments to be passed to the method. Only accepts the following +#' graphical parameters:\cr +#' adj ann ask bg bty cex.lab cex.sub cin col.axis col.lab col.main col.sub +#' cra crt csi cxy err family fg fig fin font font.axis font.lab font.main +#' font.sub lend lheight ljoin lmitre lty lwd mex mfcol mfrow mfg mkh oma 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`. +#' +#'@keywords dynamic +#'@author History:\cr +#'0.1 - 2012-09 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to CRAN +#'@examples +#'sampleData <- s2dverification::sampleDepthData +#'PlotSection(sampleData$mod[1, 1, 1, 1, , ], sampleData$lat, sampleData$depth, +#' toptitle = 'temperature 1995-11 member 0') +#'@importFrom grDevices dev.cur dev.new dev.off rainbow +#'@export +PlotSection <- function(var, horiz, depth, toptitle = '', sizetit = 1, + units = '', brks = NULL, cols = NULL, axelab = TRUE, + intydep = 200, intxhoriz = 20, drawleg = TRUE, + 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.main", "col", "lab", "las", "mai", "mar", "mgp", "new", "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 + } + + # + # Input arguments + # ~~~~~~~~~~~~~~~~~ + # + dims <- dim(var) + if (length(dims) > 2) { + stop("Only 2 dimensions expected for var : (lon,depth) or (lat,depth)") + } + if (dims[1] != length(horiz) | dims[2] != length(depth)) { + if (dims[1] == length(depth) & dims[2] == length(horiz)) { + var <- t(var) + dims <- dim(var) + } else { + stop("Inconsistent var dimensions and longitudes/latitudes + depth") + } + } + dhoriz <- horiz[2:dims[1]] - horiz[1:(dims[1] - 1)] + wher <- which(dhoriz > (mean(dhoriz) + 5)) + if (length(wher) > 0) { + horiz[(wher + 1):dims[1]] <- horiz[(wher + 1):dims[1]] - 360 + } + horizb <- sort(horiz, index.return = TRUE) + depthb <- sort(-abs(depth), index.return = TRUE) + horizmin <- floor(min(horiz) / 10) * 10 + horizmax <- ceiling(max(horiz) / 10) * 10 + depmin <- min(depth) + depmax <- max(depth) + if (is.null(brks) == TRUE) { + ll <- signif(min(var, na.rm = TRUE), 4) + ul <- signif(max(var, na.rm = TRUE), 4) + if (is.null(cols) == TRUE) { + cols <- c("dodgerblue4", "dodgerblue1", "forestgreen", "yellowgreen", + "white", "white", "yellow", "orange", "red", "saddlebrown") + } + nlev <- length(cols) + brks <- signif(seq(ll, ul, (ul - ll) / nlev), 4) + } else { + if (is.null(cols) == TRUE) { + nlev <- length(brks) - 1 + cols <- rainbow(nlev) + } else { + if (length(cols) != (length(brks) - 1)) { + stop("Inconsistent colour levels / list of colours") + } + } + } + # + # Plotting the section + # ~~~~~~~~~~~~~~~~~~ + # + + # 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) + } + + # Load the user parameters + par(userArgs) + + xmargin <- 0.5 + ymargin <- 0.5 + topmargin <- 3 + if (axelab) { + ymargin <- ymargin + 2.5 + xmargin <- xmargin + 1.5 + } + if (drawleg) { + layout(matrix(1:2, ncol = 1, nrow = 2), heights = c(5, 1)) + xmargin <- max(xmargin - 1.8, 0) + } + if (toptitle == '') { + topmargin <- topmargin - 2.5 + } + par(mar = c(xmargin, ymargin, topmargin, 0.5), cex = 1.4, + mgp = c(2.5, 0.5, 0), las = 1) + image(horizb$x, depthb$x, array(0, dims), col = 'grey', breaks = c(-1, 1), + axes = FALSE, xlab = "", ylab = "", main = toptitle, + cex.main = 1.5 * sizetit) + image(horizb$x, depthb$x, var[horizb$ix, depthb$ix], col = cols, + breaks = brks, axes = FALSE, xlab = "", ylab = "", add = TRUE) + if (axelab) { + minhoriz <- ceiling(round(min(horizb$x), 0) / 10) * 10 + maxhoriz <- floor(round(max(horizb$x), 0) / 10) * 10 + axis(1, at = seq(minhoriz, maxhoriz, intxhoriz), tck = -0.02) + maxdepth <- floor(round(max(depthb$x), 0) / 10) * 10 + axis(2, at = seq(-8000, 0, intydep), tck = -0.015) + } + box() + # + # Colorbar + # ~~~~~~~~~~ + # + if (drawleg) { + par(mar = c(1.5, ymargin, 2.5, 0.5), mgp = c(1.5, 0.3, 0), las = 1, + cex = 1.2) + image(1:length(cols), 1, t(t(1:length(cols))), axes = FALSE, col = cols, + xlab = units, ylab = '') + box() + axis(1, at = seq(0.5, length(brks) - 0.5, 1), labels = brks, cex.axis = 1) + } + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() +} diff --git a/R/PlotStereoMap.R b/R/PlotStereoMap.R new file mode 100644 index 0000000..5572f89 --- /dev/null +++ b/R/PlotStereoMap.R @@ -0,0 +1,563 @@ +#'Maps A Two-Dimensional Variable On A Polar Stereographic Projection +#' +#'Map longitude-latitude array (on a regular rectangular or gaussian grid) on +#'a polar stereographic world projection with coloured grid cells. Only the +#'region within a specified latitude interval is displayed. A colour bar +#'(legend) can be plotted and adjusted. It is possible to draw superimposed +#'dots, symbols and boxes. A number of options is provided to adjust the +#'position, size and colour of the components. This plot function is +#'compatible with figure layouts if colour bar is disabled. +#' +#'@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 latlims Latitudinal limits of the figure.\cr +#' Example : c(60, 90) for the North Pole\cr +#' c(-90,-60) for the South Pole +#'@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 filled.continents Colour to fill in drawn projected continents. Takes +#' the value gray(0.5) by default. If set to FALSE, continents are not +#' filled in. +#'@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 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 intlat Interval between latitude lines (circles), in degrees. +#' Defaults to 10. +#'@param drawleg Whether to plot a color bar (legend, key) or not. +#' Defaults to TRUE. +#'@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 to be added to the plot, +#' with the format c(y1, x1, y2, x2). Defaults to rep(1, 4). If drawleg = TRUE, +#' 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). +#'} +#' +#'@keywords dynamic +#'@author History:\cr +#'1.0 - 2014-07 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'1.1 - 2015-12 (C. Ardilouze, \email{constantin.ardilouze@@meteo.fr}) - Box(es) drawing\cr +#'1.2 - 2016-08 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Refacotred the function and +#' merged in Jean-Philippe circle +#' border and Constantin boxes. +#'@examples +#'data <- matrix(rnorm(100 * 50), 100, 50) +#'x <- seq(from = 0, to = 360, length.out = 100) +#'y <- seq(from = -90, to = 90, length.out = 50) +#'PlotStereoMap(data, x, y, latlims = c(60, 90), brks = 50, +#' toptitle = "This is the title") +#'@import mapproj +#'@importFrom grDevices dev.cur dev.new dev.off gray +#'@importFrom stats median +#'@export +PlotStereoMap <- function(var, lon, lat, latlims = c(60, 90), + 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(), + filled.continents = FALSE, coast_color = NULL, + coast_width = 1, + dots = NULL, dot_symbol = 4, dot_size = 0.8, + intlat = 10, + 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 = 6, 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.main", "col", "fin", "lab", "las", "lwd", "mai", "mar", "mgp", "new", "pch", "ps") + 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, 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.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). + if (dims[1] != length(lon) || dims[2] != length(lat)) { + if (dims[1] == length(lat) && dims[2] == length(lon)) { + var <- t(var) + 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 latlims + if (!is.numeric(latlims) || length(latlims) != 2) { + stop("Parameter 'latlims' must be a numeric vector with two elements.") + } + latlims <- sort(latlims) + center_at <- 90 * sign(latlims[which.max(abs(latlims))]) + if (max(abs(latlims - center_at)) > 90 + 20) { + stop("The range specified in 'latlims' is too wide. 110 degrees supported maximum.") + } + dlon <- median(lon[2:dims[1]] - lon[1:(dims[1] - 1)]) / 2 + dlat <- median(lat[2:dims[2]] - lat[1:(dims[2] - 1)]) / 2 + original_last_lat <- latlims[which.min(abs(latlims))] + last_lat <- lat[which.min(abs(lat - original_last_lat))] - dlat * sign(center_at) + latlims[which.min(abs(latlims))] <- last_lat + + # 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 + } + + # 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 + var_limits <- c(min(var, na.rm = TRUE), max(var, na.rm = TRUE)) + 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 filled.continents + 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 + } else if (filled.continents) { + continent_color <- gray(0.5) + } + + # 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 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 intlat + if (!is.numeric(intlat)) { + stop("Parameter 'intlat' must be numeric.") + } + + # 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 numbfig + if (!is.null(numbfig)) { + if (!is.numeric(numbfig)) { + stop("Parameter 'numbfig' must be numeric.") + } else { + numbfig <- round(numbfig) + scale <- 1 / numbfig ** 0.3 + title_scale <- title_scale * scale + margin_scale <- margin_scale * scale + dot_size <- dot_size * scale + } + } + + # + # 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.2, 4) * margin_scale + cex_title <- 2 * title_scale + if (toptitle != '') { + margins[3] <- margins[3] + cex_title + 1 + } + bar_extra_margin[1] <- bar_extra_margin[1] + margins[1] + bar_extra_margin[3] <- bar_extra_margin[3] + margins[3] + + if (drawleg) { + layout(matrix(1:2, ncol = 2, nrow = 1), widths = c(8, 2)) + } + # Load the user parameters + par(userArgs) + par(mar = margins, las = 0) + coast <- map("world", interior = FALSE, projection = "stereographic", + orientation = c(center_at, 0, 0), fill = filled.continents, + xlim = c(-180,180), ylim = latlims, wrap = TRUE, plot = FALSE) + # Compute the bounding circle + limit <- abs(mapproj::mapproject(0, last_lat, projection = 'stereographic', + orientation = c(center_at, 0, 0))$y) + for (i in 1:length(coast$x)) { + distance <- sqrt(coast$x[i]**2 + coast$y[i]**2) + if (!is.na(distance)) { + if (distance > limit) { + coast$x[i] <- coast$x[i] / distance * limit + coast$y[i] <- coast$y[i] / distance * limit + } + } + } + xcircle <- c() + ycircle <- c() + for (i in 0:500) { + xcircle <- c(xcircle, sin(2 * pi / 500 * i) * limit) + ycircle <- c(ycircle, cos(2 * pi / 500 * i) * limit) + } + circle <- list(x = xcircle, y = ycircle) + # Plot circle to set up device + plot(circle, type= 'l', axes = FALSE, lwd = 1, col = gray(0.2), asp = 1, + xlab = '', ylab = '', main = toptitle, cex.main = cex_title) + col_inf_image <- ifelse(is.null(col_inf), colNA, col_inf) + col_sup_image <- ifelse(is.null(col_sup), colNA, col_sup) + # Draw the data polygons + for (jx in 1:dims[1]) { + for (jy in 1:dims[2]) { + if (lat[jy] >= latlims[1] && latlims[2] >= lat[jy]) { + coord <- mapproj::mapproject(c(lon[jx] - dlon, lon[jx] + dlon, + lon[jx] + dlon, lon[jx] - dlon), + c(lat[jy] - dlat, lat[jy] - dlat, + lat[jy] + dlat, lat[jy] + dlat)) + if (is.na(var[jx, jy] > 0)) { + col <- colNA + } else if (var[jx, jy] <= brks[1]) { + col <- col_inf_image + } else if (var[jx, jy] >= tail(brks, 1)) { + col <- col_sup_image + } else { + ind <- which(brks[-1] >= var[jx, jy] & var[jx, jy] > brks[-length(brks)]) + col <- cols[ind] + } + polygon(coord, col = col, border = NA) + } + } + } + # Draw the dots + if (!is.null(dots)) { + numbfig <- 1 # for compatibility with PlotEquiMap code + dots <- dots[, , which(lat >= latlims[1] & lat <= latlims[2]), drop = FALSE] + data_avail <- !is.na(var[, which(lat >= latlims[1] & lat <= latlims[2]), drop = FALSE]) + for (counter in 1:(dim(dots)[1])) { + points <- which(dots[counter, , ] & data_avail, arr.ind = TRUE) + points_proj <- mapproj::mapproject(lon[points[, 1]], lat[points[, 2]]) + points(points_proj$x, points_proj$y, + pch = dot_symbol[counter], + cex = dot_size[counter] * 3 / sqrt(sqrt(sum(lat >= latlims[which.min(abs(latlims))]) * length(lon))), + lwd = dot_size[counter] * 3 / sqrt(sqrt(sum(lat >= latlims[which.min(abs(latlims))]) * length(lon)))) + } + } + + # Draw the continents, grid and bounding circle + if (filled.continents) { + old_lwd <- par('lwd') + par(lwd = coast_width) + polygon(coast, col = continent_color, border = coast_color) + par(lwd = old_lwd) + } else { + lines(coast, col = coast_color, lwd = coast_width) + } + mapproj::map.grid(lim = c(-180, 180, latlims), nx = 18, + ny = ceiling((latlims[2] - latlims[1]) / intlat), + col = 'lightgrey', labels = FALSE) + polygon(circle, border = 'black') + # Draw boxes 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 (center_at == 90 && (box[2] < original_last_lat || + box[4] > center_at) || + center_at == -90 && (box[4] > original_last_lat || + box[2] < center_at)) { + stop(paste("The limits of the", counter, + "st box defined in the parameter 'boxlim' are invalid.")) + } else { + mapproj::map.grid(lim = c(box[1], box[3], box[2], box[4]), + nx = 2, ny = 2, pretty = FALSE, + col = boxcol[counter], lty = "solid", + lwd = boxlwd[counter], labels = FALSE) + } + counter <- counter + 1 + } + } + + # + # Colorbar + # ~~~~~~~~~~ + # + if (drawleg) { + ColorBar(brks, cols, TRUE, 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)) +} diff --git a/R/PlotVsLTime.R b/R/PlotVsLTime.R new file mode 100644 index 0000000..8920438 --- /dev/null +++ b/R/PlotVsLTime.R @@ -0,0 +1,271 @@ +#'Plots A Score Along The Forecast Time With Its Confidence Interval +#' +#'Plots The Correlation (\code{Corr()}) or the Root Mean Square Error +#'(\code{RMS()}) between the forecasted values and their observational +#'counterpart or the slopes of their trends (\code{Trend()}) or the +#'InterQuartile Range, Maximum-Mininum, Standard Deviation or Median Absolute +#'Deviation of the Ensemble Members (\code{Spread()}), or the ratio between +#'the Ensemble Spread and the RMSE of the Ensemble Mean (\code{RatioSDRMS()}) +#'along the forecast time for all the input experiments on the same figure +#'with their confidence intervals. +#' +#'@param var Matrix containing any Prediction Score with dimensions:\cr +#' (nexp/nmod, 3/4 ,nltime)\cr +#' or (nexp/nmod, nobs, 3/4 ,nltime). +#'@param toptitle Main title, optional. +#'@param ytitle Title of Y-axis, optional. +#'@param monini Starting month between 1 and 12. Default = 1. +#'@param freq 1 = yearly, 12 = monthly, 4 = seasonal, ... Default = 12. +#'@param nticks Number of ticks and labels on the x-axis, optional. +#'@param limits c(lower limit, upper limit): limits of the Y-axis, optional. +#'@param listexp List of experiment names, optional. +#'@param listobs List of observation names, optional. +#'@param biglab TRUE/FALSE for presentation/paper plot. Default = FALSE. +#'@param hlines c(a,b, ..) Add horizontal black lines at Y-positions a,b, ...\cr +#' Default = NULL. +#'@param leg TRUE/FALSE if legend should be added or not to the plot. +#' Default = TRUE. +#'@param siglev TRUE/FALSE if significance level should replace confidence +#' interval.\cr +#' Default = FALSE. +#'@param sizetit Multiplicative factor to change title size, optional. +#'@param show_conf TRUE/FALSE to show/not confidence intervals for input +#' variables. +#'@param fileout Name of output file. Extensions allowed: eps/ps, jpeg, png, +#' pdf, bmp and tiff.\cr +#' Default = 'output_plotvsltime.eps' +#'@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 ... 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 fig font font.axis font.lab font.main font.sub +#' lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page pch plt +#' smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +#' For more information about the parameters see `par`. +#' +#'@details +#'Examples of input:\cr +#'Model and observed output from \code{Load()} then \code{Clim()} then +#'\code{Ano()} then \code{Smoothing()}:\cr +#'(nmod, nmemb, nsdate, nltime) and (nobs, nmemb, nsdate, nltime)\cr +#'then averaged over the members\cr +#'\code{Mean1Dim(var_exp/var_obs, posdim = 2)}:\cr +#'(nmod, nsdate, nltime) and (nobs, nsdate, nltime)\cr +#'then passed through\cr +#' \code{Corr(exp, obs, posloop = 1, poscor = 2)} or\cr +#' \code{RMS(exp, obs, posloop = 1, posRMS = 2)}:\cr +#' (nmod, nobs, 3, nltime)\cr +#'would plot the correlations or RMS between each exp & each obs as a function +#'of the forecast time. +#' +#'@keywords dynamic +#'@author History:\cr +#'0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@@ic3.cat}) - Original code\cr +#'0.2 - 2013-03 (I. Andreu-Burillo, \email{isabel.andreu-burillo@@ic3.cat}) - Introduced parameter sizetit\cr +#'0.3 - 2013-10 (I. Andreu-Burillo, \email{isabel.andreu-burillo@@ic3.cat}) - Introduced parameter show_conf\cr +#'1.0 - 2013-11 (N. Manubens, \email{nicolau.manubens@@ic3.cat}) - Formatting to CRAN +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'clim <- Clim(sampleData$mod, sampleData$obs) +#'ano_exp <- Ano(sampleData$mod, clim$clim_exp) +#'ano_obs <- Ano(sampleData$obs, clim$clim_obs) +#'runmean_months <- 12 +#'dim_to_smooth <- 4 # Smooth along lead-times +#'smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +#'smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +#'dim_to_mean <- 2 # Mean along members +#'required_complete_row <- 3 # Discard startdates for which there are NA leadtimes +#'leadtimes_per_startdate <- 60 +#'corr <- Corr(Mean1Dim(smooth_ano_exp, dim_to_mean), +#' Mean1Dim(smooth_ano_obs, dim_to_mean), +#' compROW = required_complete_row, +#' limits = c(ceiling((runmean_months + 1) / 2), +#' leadtimes_per_startdate - floor(runmean_months / 2))) +#' \donttest{ +#'PlotVsLTime(corr, toptitle = "correlations", ytitle = "correlation", +#' monini = 11, limits = c(-1, 2), listexp = c('CMIP5 IC3'), +#' listobs = c('ERSST'), biglab = FALSE, hlines = c(-1, 0, 1), +#' fileout = 'tos_cor.eps') +#' } +#' +#'@importFrom grDevices dev.cur dev.new dev.off +#'@importFrom stats ts +#'@export +PlotVsLTime <- function(var, toptitle = '', ytitle = '', monini = 1, freq = 12, + nticks = NULL, limits = NULL, + listexp = c('exp1', 'exp2', 'exp3'), + listobs = c('obs1', 'obs2', 'obs3'), biglab = FALSE, hlines = NULL, + leg = TRUE, siglev = FALSE, sizetit = 1, show_conf = TRUE, + fileout = 'output_plotvsltime.eps', + 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", "fin", "lab", "las", "lend", "lty", "lwd", "mai", "mgp", "new", "pin", "ps", "pty") + 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 + } + + # + # Get some arguments + # ~~~~~~~~~~~~~~~~~~~~ + # + if (length(dim(var)) == 3) { + var <- InsertDim(var, posdim = 2, lendim = 1) + } else if (length(dim(var)) != 4) { + stop("Parameter 'var' should have 3 or 4 dimensions: c(n. exp[, n. obs], 3/4, n. lead-times)") + } + nleadtime <- dim(var)[4] + nexp <- dim(var)[1] + nobs <- dim(var)[2] + if (is.null(limits) == TRUE) { + if (all(is.na(var > 0))) { + ll <- ul <- 0 + } else { + ll <- min(var, na.rm = TRUE) + ul <- max(var, na.rm = TRUE) + } + if (biglab) { + ul <- ul + 0.4 * (ul - ll) + } else { + ul <- ul + 0.3 * (ul - ll) + } + } else { + ll <- limits[1] + ul <- limits[2] + } + lastyear <- (monini + (nleadtime - 1) * 12 / freq - 1) %/% 12 + lastmonth <- (monini + (nleadtime - 1) * 12 / freq - 1) %% 12 + 1 + empty_ts <- ts(start = c(0000, (monini - 1) %/% (12 / freq) + 1), + end = c(lastyear, (lastmonth - 1) %/% (12 / freq) + 1), + frequency = freq) + empty <- array(dim = length(empty_ts)) + # + # Define some plot parameters + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + if (is.null(nticks)) { + if (biglab) { + nticks <- 5 + } else { + nticks <- 10 + } + } + labind <- seq(1, nleadtime, max(nleadtime %/% nticks, 1)) + months <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", + "Oct", "Nov", "Dec") + labyear <- ((labind - 1) * 12 / freq + monini - 1) %/% 12 + labmonth <- months[((labind - 1) * 12 / freq + monini -1 ) %% 12 + 1] + for (jx in 1:length(labmonth)) { + y2o3dig <- paste("0", as.character(labyear[jx]), sep = "") + labmonth[jx] <- paste(labmonth[jx], "\nYr ", substr(y2o3dig, nchar(y2o3dig) + - 1, nchar(y2o3dig)), sep = "") + } + color <- c("red1", "dodgerblue1", "green1", "orange1", "lightblue1", + "deeppink1", "mediumpurple1", "lightgoldenrod1", "olivedrab1", + "mediumorchid1") + type <- c(1, 3, 2, 4) + thickness <- array(dim = c(4, 4)) + thickness[, 1] <- c(1, 2, 1, 1.5) + thickness[, 2] <- c(8, 12, 8, 10) + thickness[, 3] <- thickness[, 1] + thickness[, 4] <- c(4, 6, 4, 5) + if (siglev == TRUE) { + lines <- c("n", "l", "n", "l") + } else { + lines <- c("l", "l", "l", "n") + } + # + # Define plot layout + # ~~~~~~~~~~~~~~~~~~~~ + # + + # 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) + } + + # Load the user parameters + par(userArgs) + + if (biglab) { + par(mai = c(1.25, 1.4, 0.5, 1), mgp = c(4, 2.5, 0)) + par(cex = 1.3, cex.lab = 2, cex.axis = 1.8) + cexmain <- 2.2 + legsize <- 1.5 + } else { + par(mai = c(1, 1.1, 0.5, 0), mgp = c(3, 1.8, 0)) + par(cex = 1.3, cex.lab = 1.5, cex.axis = 1.1) + cexmain <- 1.5 + legsize <- 1 + } + plot(empty, ylim = c(ll, ul), xlab = "Time (months)", ylab = ytitle, + main = toptitle, cex.main = cexmain*sizetit, axes = FALSE) + axis(1, at = labind, labels = labmonth) + axis(2) + box() + if (is.null(hlines) != TRUE) { + for (jy in 1:length(hlines)) { + par(new = TRUE) + abline(h = hlines[jy]) + } + } + # + # Loop on experimental & observational data + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + # + legendnames <- array(dim = nobs * nexp) + legendthick <- array(dim = nobs * nexp) + legendsty <- array(dim = nobs * nexp) + legendcol <- array(dim = nobs * nexp) + ind <- 1 + if (show_conf == TRUE) { + start_line <- dim(var)[3] + end_line <- 1 + } else { + start_line <- 2 + end_line <- 2 + } + for (jt in seq(start_line, end_line, -1)) { + ind <- 1 + for (jexp in 1:nexp) { + for (jobs in 1:nobs) { + par(new = TRUE) + plot(var[jexp, jobs, jt, ], type = lines[jt], ylim = c(ll, ul), + col = color[jexp], lty = type[jobs], lwd = thickness[jobs, jt], + ylab = "", xlab = "", axes = FALSE) + legendnames[ind] <- paste(listexp[jexp], 'vs', listobs[jobs]) + legendthick[ind] <- thickness[jobs, 1] * 3 + legendsty[ind] <- type[jobs] + legendcol[ind] <- color[jexp] + ind <- ind + 1 + } + } + } + if (leg) { + if (nobs == 1) { + legendnames <- listexp[1:nexp] + } + legend(1, ul, legendnames, lty = legendsty, lwd = legendthick, + col = legendcol, cex = legsize) + } + + # If the graphic was saved to file, close the connection with the device + if(!is.null(fileout)) dev.off() +} diff --git a/R/ToyModel.R b/R/ToyModel.R new file mode 100644 index 0000000..4b06fac --- /dev/null +++ b/R/ToyModel.R @@ -0,0 +1,203 @@ +#'Synthetic forecast generator imitating seasonal to decadal forecasts. The +#'components of a forecast: (1) predictabiltiy (2) forecast error (3) +#'non-stationarity and (4) ensemble generation. The forecast can be computed +#'for real observations or observations generated artifically. +#' +#'The toymodel is based on the model presented in Weigel et al. (2008) QJRS +#'with an extension to consider non-stationary distributions prescribing a +#'linear trend. The toymodel allows to generate an aritifical forecast +#'based on obsevations provided by the input (from Load) or artificially +#'generated observations based on the input parameters (sig, trend). +#'The forecast can be specfied for any number of start-dates, lead-time and +#'ensemble members. It imitates components of a forecast: (1) predictabiltiy +#'(2) forecast error (3) non-stationarity and (4) ensemble generation. +#'The forecast can be computed for real observations or observations generated +#'artifically. +#' +#'@param alpha Predicabiltiy of the forecast on the observed residuals +#' Must be a scalar 0 < alpha < 1. +#'@param beta Standard deviation of forecast error +#' Must be a scalar 0 < beta < 1. +#'@param gamma Factor on the linear trend to sample model uncertainty. Can be +#' a scalar or a vector of scalars -inf < gammay < inf. +#' Defining a scalar results in multiple forecast, corresponding to different +#' models with different trends. +#'@param sig Standard deviation of the residual variability of the forecast. +#' If observations are provided 'sig' is computed from the observations. +#'@param trend Linear trend of the forecast. The same trend is used for each +#' lead-time. If observations are provided the 'trend' is computed from the +#' observations, with potentially different trends for each lead-time. The +#' trend has no unit and needs to be defined according to the time vector +#' [1,2,3,... nstartd]. +#'@param nstartd Number of start-dates of the forecast. +#' If observations are provided the 'nstartd' is computed from the observations. +#'@param nleadt Number of lead-times of the forecats. +#' If observations are provided the 'nleadt' is computed from the observations. +#'@param nmemb Number of members of the forecasts. +#'@param obsini Observations that can be used in the synthetic forecast coming +#' from Load (anomalies are expected). If no observations are provided +#' artifical observations are generated based on Gaussian variaiblity with +#' standard deviation from 'sig' and linear trend from 'trend'. +#'@param fxerr Provides a fixed error of the forecast instead of generating +#' one from the level of beta. This allows to perform pair of forecasts with +#' the same conditional error as required for instance in an attribution context. +#' +#'@return List of forecast with $mod including the forecast and $obs the +#' observations. The dimensions correspond to +#' c(length(gamma), nmemb, nstartd, nleadt) +#' +#'@keywords datagen +#'@author History:\cr +#'1.0 - 2014-08 (O.Bellprat) - Original code +#'1.1 - 2016-02 (O.Bellprat) - Include security check for parameters +#'@examples +#'# Example 1: Generate forecast with artifical observations +#'# Seasonal prediction example +#'a <- 0.1 +#'b <- 0.3 +#'g <- 1 +#'sig <- 1 +#'t <- 0.02 +#'ntd <- 30 +#'nlt <- 4 +#'nm <- 10 +#'toyforecast <- ToyModel(alpha = a, beta = b, gamma = g, sig = sig, trend = t, +#' nstartd = ntd, nleadt = nlt, nmemb = nm) +#' +#'# Example 2: Generate forecast from loaded observations +#'# Decadal prediction example +#' \dontrun{ +#'data_path <- system.file('sample_data', package = 's2dverification') +#'expA <- list(name = 'experiment', path = file.path(data_path, +#' 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', +#' '$VAR_NAME$_$START_DATE$.nc')) +#'obsX <- list(name = 'observation', path = file.path(data_path, +#' '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', +#' '$VAR_NAME$_$YEAR$$MONTH$.nc')) +#' +#'# Now we are ready to use Load(). +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- Load('tos', list(expA), list(obsX), startDates, +#' output = 'areave', latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' output = 'areave', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#' } +#' +#'a <- 0.1 +#'b <- 0.3 +#'g <- 1 +#'nm <- 10 +#' +#'toyforecast <- ToyModel(alpha = a, beta = b, gamma = g, nmemb = nm, +#' obsini = sampleData$obs, nstartd = 5, nleadt = 60) +#' \donttest{ +#'PlotAno(toyforecast$mod, toyforecast$obs, startDates, +#' toptitle = c("Synthetic decadal temperature prediction"), +#' fileout = "ex_toymodel.eps") +#' } +#' +#'@importFrom stats rnorm +#'@export +ToyModel <- function(alpha = 0.1, beta = 0.4, gamma = 1, sig = 1, + trend = 0, nstartd = 30, nleadt = 4, nmemb = 10, obsini = NULL, + fxerr = NULL) { + # Check alpha, beta, gamma, sig, trend, nstartd, nleadt, nmemb + if (any(!is.numeric(c(alpha, beta, gamma, sig, trend, nstartd, + nleadt, nmemb)))) { + stop(paste("Parameters 'alpha', 'beta', 'gamma', 'sig', 'trend', 'nstartd',", + "nleadt and nmemb must be numeric.")) + } + nstartd <- round(nstartd) + nleadt <- round(nleadt) + nmemb <- round(nmemb) + + # Check obsini + if (!is.null(obsini)) { + if (!is.numeric(obsini) || !is.array(obsini)) { + stop("Parameter 'obsini' must be a numeric array.") + } + if (length(dim(obsini)) != 4) { + stop("Parameter 'obsini' must be an array with dimensions c(1, 1, nleadt, nstartd).") + } + if (dim(obsini)[3] != nstartd || dim(obsini)[4] != nleadt) { + stop(paste0("The dimensions of parameter 'obsini' and the parameters 'nleadt' and 'nstartd' must match:\n dim(obsini) = c(", + dim(obsini)[3], ", ", dim(obsini)[4], ")\n nstartd = ", nstartd, " nleadt = ", nleadt)) + } + } + + # Check fxerr + if (!is.null(fxerr)) { + if (!is.numeric(fxerr)) { + stop("Parameter 'fxerr' must be numeric.") + } + } + + time <- seq(1, nstartd) # time vector, generated from 1 -> nstard + + if (!(sig^2 - alpha^2 - beta^2 > 0)) { + stop("Model variability not constrained: respect condition \"sig^2-alpha^2-beta^2 > 0\")") + } + + if (nstartd < 0) { + stop("Number of start dates must be positive") + } + + if (nleadt < 0) { + stop("Number of lead-times must be positive") + } + + if (nmemb < 0) { + stop("Number of members must be positive") + } + + + if (!is.null(obsini)) { + # Observations provided by input compute forecast parameters + # from observations + obs_ano <- obsini + } else { + # Create observations for selected period + obs_ano <- array(rnorm(nleadt * nstartd, mean = 0, sd = sig), + dim = c(1, 1, nstartd, nleadt)) + obs_trend <- array(t(time) * rep(trend, times = nstartd), + , dim = c(1, 1, nstartd, nleadt)) + obs <- obs_ano + obs_trend + + trend <- rep(c(trend), times = nleadt) # same trend in all lead-times + sig <- rep(c(sig), times = nleadt) # same variability in all lead-times + } + + forecast <- array(dim = c(length(gamma), nmemb, nstartd, + nleadt)) + + # Allocate observations and forecast according to + # s2dverification standards + for (j in 1:nstartd) { + for (f in 1:nleadt) { + for (g in 1:length(gamma)) { + # Generate forecasts with different trends + auto_term <- alpha * obs_ano[1, 1, j, f] # Predictability term + if (is.numeric(fxerr)) { + conf_term <- fxerr # Forecast error term, fixed by input + } else { + conf_term <- rnorm(1, mean = 0, sd = beta) # Forecast error term, random + } + trend_term <- gamma[g] * trend[f] * j # Trend term + var_corr <- rnorm(nmemb, mean = 0, sd = sqrt(sig[f] - + alpha^2 - beta^2)) + forecast[g, , j, f] <- matrix(auto_term, c(nmemb, + 1)) + matrix(conf_term, c(nmemb, 1)) + matrix(trend_term, + c(nmemb, 1)) + var_corr + } + } + } + + list(mod = forecast, obs = obs_ano) +} diff --git a/R/clim.palette.R b/R/clim.palette.R new file mode 100644 index 0000000..d18dab1 --- /dev/null +++ b/R/clim.palette.R @@ -0,0 +1,58 @@ +#'Generate Climate Color Palettes +#' +#'Generates a colorblind friendly color palette with color ranges useful in +#'climate temperature variable plotting. +#' +#'@param palette Which type of palette to generate: from blue through white +#' to red ('bluered'), from red through white to blue ('redblue'), from +#' yellow through orange to red ('yellowred'), or from red through orange +#' to red ('redyellow'). +#'@param n Number of colors to generate. +#' +#'@keywords datagen +#'@author History:\cr +#'0.0 - 2016-01 (N. Manubens, \email{nicolau.manubens@@bsc.es}) - Original code. +#'@examples +#'lims <- seq(-1, 1, length.out = 21) +#' +#'ColorBar(lims, color_fun = clim.palette('redyellow')) +#' +#'cols <- clim.colors(20) +#'ColorBar(lims, cols) +#' +#'@rdname clim.palette +#'@importFrom grDevices colorRampPalette +#'@export +clim.palette <- function(palette = "bluered") { + if (palette == "bluered") { + colorbar <- colorRampPalette(rev(c("#67001f", "#b2182b", "#d6604d", + "#f4a582", "#fddbc7", "#f7f7f7", + "#d1e5f0", "#92c5de", "#4393c3", + "#2166ac", "#053061"))) + attr(colorbar, 'na_color') <- 'pink' + } else if (palette == "redblue") { + colorbar <- colorRampPalette(c("#67001f", "#b2182b", "#d6604d", + "#f4a582", "#fddbc7", "#f7f7f7", + "#d1e5f0", "#92c5de", "#4393c3", + "#2166ac", "#053061")) + attr(colorbar, 'na_color') <- 'pink' + } else if (palette == "yellowred") { + colorbar <- colorRampPalette(c("#ffffcc", "#ffeda0", "#fed976", + "#feb24c", "#fd8d3c", "#fc4e2a", + "#e31a1c", "#bd0026", "#800026")) + attr(colorbar, 'na_color') <- 'pink' + } else if (palette == "redyellow") { + colorbar <- colorRampPalette(rev(c("#ffffcc", "#ffeda0", "#fed976", + "#feb24c", "#fd8d3c", "#fc4e2a", + "#e31a1c", "#bd0026", "#800026"))) + attr(colorbar, 'na_color') <- 'pink' + } else { + stop("Parameter 'palette' must be one of 'bluered', 'redblue', 'yellowred' or 'redyellow'.") + } + colorbar +} +#'@rdname clim.palette +#'@export +clim.colors <- function(n, palette = "bluered") { + clim.palette(palette)(n) +} diff --git a/man/AnimateMap.Rd b/man/AnimateMap.Rd new file mode 100644 index 0000000..96074b0 --- /dev/null +++ b/man/AnimateMap.Rd @@ -0,0 +1,197 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AnimateMap.R +\name{AnimateMap} +\alias{AnimateMap} +\title{Animate Maps of Forecast/Observed Values or Scores Over Forecast Time} +\usage{ +AnimateMap(var, lon, lat, toptitle = rep("", 11), sizetit = 1, units = "", + monini = 1, freq = 12, msk95lev = FALSE, brks = NULL, cols = NULL, + filled.continents = FALSE, lonmin = 0, lonmax = 360, latmin = -90, + latmax = 90, intlon = 20, intlat = 30, drawleg = TRUE, + subsampleg = 1, colNA = "white", equi = TRUE, + fileout = c("output1_animvsltime.gif", "output2_animvsltime.gif", + "output3_animvsltime.gif"), ...) +} +\arguments{ +\item{var}{Matrix of dimensions (nltime, nlat, nlon) or +(nexp/nmod, nltime, nlat, nlon) or (nexp/nmod, 3/4, nltime, nlat, nlon) or +(nexp/nmod, nobs, 3/4, nltime, nlat, nlon).} + +\item{lon}{Vector containing longtitudes (degrees).} + +\item{lat}{Vector containing latitudes (degrees).} + +\item{toptitle}{c('','', \dots) array of main title for each animation, +optional. If RMS, RMSSS, correlations: first exp with successive obs, then +second exp with successive obs, etc ...} + +\item{sizetit}{Multiplicative factor to increase title size, optional.} + +\item{units}{Units, optional.} + +\item{monini}{Starting month between 1 and 12. Default = 1.} + +\item{freq}{1 = yearly, 12 = monthly, 4 = seasonal ...} + +\item{msk95lev}{TRUE/FALSE grid points with dots if 95\% significance level +reached. Default = FALSE.} + +\item{brks}{Limits of colour levels, optional. For example: +seq(min(var), max(var), (max(var) - min(var)) / 10).} + +\item{cols}{Vector of colours of length(brks) - 1, optional.} + +\item{filled.continents}{Continents filled in grey (TRUE) or represented by +a black line (FALSE). Default = TRUE. Filling unavailable if crossing +Greenwich and equi = TRUE. Filling unavailable if square = FALSE and +equi = TRUE.} + +\item{lonmin}{Westward limit of the domain to plot (> 0 or < 0). +Default : 0 degrees.} + +\item{lonmax}{Eastward limit of the domain to plot (> 0 or < 0). +lonmax > lonmin. Default : 360 degrees.} + +\item{latmin}{Southward limit of the domain to plot. Default : -90 degrees.} + +\item{latmax}{Northward limit of the domain to plot. Default : 90 degrees.} + +\item{intlon}{Interval between longitude ticks on x-axis. +Default = 20 degrees.} + +\item{intlat}{Interval between latitude ticks on y-axis for equi = TRUE or +between latitude circles for equi = FALSE. Default = 30 degrees.} + +\item{drawleg}{Draw a colorbar. Can be FALSE only if square = FALSE or +equi = FALSE. Default = TRUE.} + +\item{subsampleg}{Supsampling factor of the interval between ticks on +colorbar. Default = 1 = every colour level.} + +\item{colNA}{Color used to represent NA. Default = 'white'.} + +\item{equi}{TRUE/FALSE == cylindrical equidistant/stereographic projection. +Default: TRUE.} + +\item{fileout}{c('', '', \dots) array of output file name for each animation. + If RMS, RMSSS, correlations : first exp with successive obs, then second +exp with successive obs, etc ...} + +\item{...}{Arguments to be passed to the method. Only accepts the following +graphical parameters:\cr +adj ann ask bty cex cex.axis cex.lab cex.main cex.sub + cin col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig +font font.axis font.lab font.main font.sub las lheight ljoin lmitre lty +lwd mai mar mex mfcol mfrow mfg mgp mkh oma omd omi page pch plt pty smo +srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog. \cr +For more information about the parameters see `par`.} +} +\description{ +Create animations of maps in an equi-rectangular or stereographic +projection, showing the anomalies, the climatologies, the mean InterQuartile +Range, Maximum-Mininum, Standard Deviation, Median Absolute Deviation, +the trends, the RMSE, the correlation or the RMSSS, between modelled and +observed data along the forecast time (lead-time) for all input experiments +and input observational datasets. +} +\details{ +Examples of input: +\enumerate{ + \item{ + Outputs from clim (exp, obs, memb = FALSE): + (nmod, nltime, nlat, nlon) + or (nobs, nltime, nlat, nlon) + } + \item{ + Model output from load/ano/smoothing: + (nmod, nmemb, sdate, nltime, nlat, nlon) + then passed through spread(var, posdim = 2, narm = TRUE) + & mean1dim(var, posdim = 3, narm = TRUE) + or through trend(mean1dim(var, 2), posTR = 2): + (nmod, 3, nltime, nlat, nlon) + animates average along start dates of IQR/MaxMin/SD/MAD across members + or trends of the ensemble-mean computed accross the start dates. + } + \item{ + model and observed output from load/ano/smoothing: + (nmod, nmemb, sdate, nltime, nlat, nlon) + & (nobs, nmemb, sdate, nltime, nlat, nlon) + then averaged along members mean1dim(var_exp/var_obs, posdim = 2): + (nmod, sdate, nltime, nlat, nlon) + (nobs, sdate, nltime, nlat, nlon) + then passed through corr(exp, obs, posloop = 1, poscor = 2) + or RMS(exp, obs, posloop = 1, posRMS = 2): + (nmod, nobs, 3, nltime, nlat, nlon) + animates correlations or RMS between each exp & each obs against leadtime. + } +} +} +\examples{ +# See ?Load for explanations on the first part of this example + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + output = 'lonlat', latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } +clim <- Clim(sampleData$mod, sampleData$obs, memb = FALSE) + \dontrun{ +AnimateMap(clim$clim_exp, sampleData$lon, sampleData$lat, + toptitle = "climatology of decadal prediction", sizetit = 1, + units = "degree", brks = seq(270, 300, 3), monini = 11, freq = 12, + msk95lev = FALSE, filled.continents = TRUE, intlon = 10, intlat = 10, + fileout = 'clim_dec.gif') + } +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +leadtimes_dimension <- 4 +initial_month <- 11 +mean_start_month <- 1 +mean_stop_month <- 12 +season_means_mod <- Season(ano_exp, leadtimes_dimension, initial_month, + mean_start_month, mean_stop_month) +season_means_obs <- Season(ano_obs, leadtimes_dimension, initial_month, + mean_start_month, mean_stop_month) + \dontrun{ +AnimateMap(Mean1Dim(season_means_mod, 2)[1, 1, , , ], sampleData$lon, + sampleData$lat, toptitle = "Annual anomalies 1985 of decadal prediction", + sizetit = 1, units = "degree", monini = 1, freq = 1, msk95lev = FALSE, + brks = seq(-0.5, 0.5, 0.1), intlon = 10, intlat = 10, + filled.continents = TRUE, fileout = 'annual_means_dec.gif') + } +dim_to_mean <- 2 # Mean along members +rms <- RMS(Mean1Dim(season_means_mod, dim_to_mean), + Mean1Dim(season_means_obs, dim_to_mean)) + \donttest{ +AnimateMap(rms, sampleData$lon, sampleData$lat, toptitle = + "RMSE decadal prediction", sizetit = 1, units = "degree", + monini = 1, freq = 1, msk95lev = FALSE, brks = seq(0, 0.8, 0.08), + intlon = 10, intlat = 10, filled.continents = TRUE, + fileout = 'rmse_dec.gif') + } +} +\author{ +History:\cr + 1.0 - 2012-04 (V. Guemas, \email{virginie.guemas@bsc.es}) - Original code\cr + 1.1 - 2014-04 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to CRAN\cr + 1.2 - 2015-05 (V. Guemas, \email{virginie.guemas@bsc.es}) - Use of PlotEquiMap and PlotStereoMap +} +\keyword{dynamic} + diff --git a/man/CDORemap.Rd b/man/CDORemap.Rd new file mode 100644 index 0000000..b2d5eaa --- /dev/null +++ b/man/CDORemap.Rd @@ -0,0 +1,229 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/CDORemap.R +\name{CDORemap} +\alias{CDORemap} +\title{Interpolates arrays with longitude and latitude dimensions using CDO} +\usage{ +CDORemap(data_array = NULL, lons, lats, grid, method, avoid_writes = TRUE, + crop = TRUE, force_remap = FALSE, write_dir = tempdir()) +} +\arguments{ +\item{data_array}{Multidimensional numeric array to be interpolated. If +provided, it must have at least a longitude and a latitude dimensions, +identified by the array dimension names. The names for these dimensions +must be one of the recognized by s2dverification (can be checked with +\code{s2dverification:::.KnownLonNames()} and +\code{s2dverification:::.KnownLatNames()}).} + +\item{lons}{Numeric vector or array of longitudes of the centers of the grid +cells. Its size must match the size of the longitude/latitude dimensions +of the input array.} + +\item{lats}{Numeric vector or array of latitudes of the centers of the grid +cells. Its size must match the size of the longitude/latitude dimensions +of the input array.} + +\item{grid}{Character string specifying either a name of a target grid +(recognized by CDO; e.g.: 'r256x128', 't106grid') or a path to another +NetCDF file which to read the target grid from (a single grid must be +defined in such file).} + +\item{method}{Character string specifying an interpolation method +(recognized by CDO; e.g.: 'con', 'bil', 'bic', 'dis'). The following +long names are also supported: 'conservative', 'bilinear', 'bicubic' and +'distance-weighted'.} + +\item{avoid_writes}{The step of permutation is needed when the input array +has more than 3 dimensions and none of the longitude or latitude dimensions + in the right-most position (CDO would not accept it without permuting +previously). This step, executed by default when needed, can be avoided +for the price of writing more intermediate files (whis usually is +unconvenient) by setting the parameter \code{avoid_writes = TRUE}.} + +\item{crop}{Whether to crop the data after interpolation with +'cdo sellonlatbox' (TRUE) or to extend interpolated data to the whole +world as CDO does by default (FALSE). If \code{crop = TRUE} then the +longitude and latitude borders which to crop at are taken as the limits of +the cells at the borders ('lons' and 'lats' are perceived as cell centers), +i.e. the resulting array will contain data that covers the same area as +the input array. This is equivalent to specifying \code{crop = 'preserve'}, +i.e. preserving area. If \code{crop = 'tight'} then the borders which to +crop at are taken as the minimum and maximum cell centers in 'lons' and +'lats', i.e. the area covered by the resulting array may be smaller if +interpolating from a coarse grid to a fine grid. The parameter 'crop' also +accepts a numeric vector of custom borders which to crop at: +c(western border, eastern border, southern border, northern border).} + +\item{force_remap}{Whether to force remapping, even if the input data array +is already on the target grid.} + +\item{write_dir}{Path to the directory where to create the intermediate +files for CDO to work. By default, the R session temporary directory is +used (\code{tempdir()}).} +} +\value{ +A list with the following components: + \item{'data_array'}{The interpolated data array (if an input array + is provided at all, NULL otherwise).} + \item{'lons'}{The longitudes of the data on the destination grid.} + \item{'lats'}{The latitudes of the data on the destination grid.} +} +\description{ +This function takes as inputs a multidimensional array (optional), a vector +or matrix of longitudes, a vector or matrix of latitudes, a destination grid +specification, and the name of a method to be used to interpolate (one of +those available in the 'remap' utility in CDO). The interpolated array is +returned (if provided) together with the new longitudes and latitudes.\cr\cr +\code{CDORemap()} permutes by default the dimensions of the input array (if +needed), splits it in chunks (CDO can work with data arrays of up to 4 +dimensions), generates a file with the data of each chunk, interpolates it +with CDO, reads it back into R and merges it into a result array. If no +input array is provided, the longitude and latitude vectors will be +transformed only. If the array is already on the desired destination grid, +no transformation is performed (this behvaiour works only for lonlat and +gaussian grids). \cr\cr +Any metadata attached to the input data array, longitudes or latitudes will +be preserved or accordingly modified. +} +\examples{ + \dontrun{ +# Interpolating only vectors of longitudes and latitudes +lon <- seq(0, 360 - 360/50, length.out = 50) +lat <- seq(-90, 90, length.out = 25) +tas2 <- CDORemap(NULL, lon, lat, 't170grid', 'bil', TRUE) + +# Minimal array interpolation +tas <- array(1:50, dim = c(25, 50)) +names(dim(tas)) <- c('lat', 'lon') +lon <- seq(0, 360 - 360/50, length.out = 50) +lat <- seq(-90, 90, length.out = 25) +tas2 <- CDORemap(tas, lon, lat, 't170grid', 'bil', TRUE) + +# Metadata can be attached to the inputs. It will be preserved and +# accordignly modified. +tas <- array(1:50, dim = c(25, 50)) +names(dim(tas)) <- c('lat', 'lon') +lon <- seq(0, 360 - 360/50, length.out = 50) +metadata <- list(lon = list(units = 'degrees_east')) +attr(lon, 'variables') <- metadata +lat <- seq(-90, 90, length.out = 25) +metadata <- list(lat = list(units = 'degrees_north')) +attr(lat, 'variables') <- metadata +metadata <- list(tas = list(dim = list(lat = list(len = 25, + vals = lat), + lon = list(len = 50, + vals = lon) + ))) +attr(tas, 'variables') <- metadata +tas2 <- CDORemap(tas, lon, lat, 't170grid', 'bil', TRUE) + +# Arrays of any number of dimensions in any order can be provided. +num_lats <- 25 +num_lons <- 50 +tas <- array(1:(10*num_lats*10*num_lons*10), + dim = c(10, num_lats, 10, num_lons, 10)) +names(dim(tas)) <- c('a', 'lat', 'b', 'lon', 'c') +lon <- seq(0, 360 - 360/num_lons, length.out = num_lons) +metadata <- list(lon = list(units = 'degrees_east')) +attr(lon, 'variables') <- metadata +lat <- seq(-90, 90, length.out = num_lats) +metadata <- list(lat = list(units = 'degrees_north')) +attr(lat, 'variables') <- metadata +metadata <- list(tas = list(dim = list(a = list(), + lat = list(len = num_lats, + vals = lat), + b = list(), + lon = list(len = num_lons, + vals = lon), + c = list() + ))) +attr(tas, 'variables') <- metadata +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', TRUE) +# The step of permutation can be avoided but more intermediate file writes +# will be performed. +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', FALSE) + +# If the provided array has the longitude or latitude dimension in the +# right-most position, the same number of file writes will be performed, +# even if avoid_wrties = FALSE. +num_lats <- 25 +num_lons <- 50 +tas <- array(1:(10*num_lats*10*num_lons*10), + dim = c(10, num_lats, 10, num_lons)) +names(dim(tas)) <- c('a', 'lat', 'b', 'lon') +lon <- seq(0, 360 - 360/num_lons, length.out = num_lons) +metadata <- list(lon = list(units = 'degrees_east')) +attr(lon, 'variables') <- metadata +lat <- seq(-90, 90, length.out = num_lats) +metadata <- list(lat = list(units = 'degrees_north')) +attr(lat, 'variables') <- metadata +metadata <- list(tas = list(dim = list(a = list(), + lat = list(len = num_lats, + vals = lat), + b = list(), + lon = list(len = num_lons, + vals = lon) + ))) +attr(tas, 'variables') <- metadata +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', TRUE) +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', FALSE) + +# An example of an interpolation from and onto a rectangular regular grid +num_lats <- 25 +num_lons <- 50 +tas <- array(1:(1*num_lats*num_lons), dim = c(num_lats, num_lons)) +names(dim(tas)) <- c('y', 'x') +lon <- array(seq(0, 360 - 360/num_lons, length.out = num_lons), + dim = c(num_lons, num_lats)) +metadata <- list(lon = list(units = 'degrees_east')) +names(dim(lon)) <- c('x', 'y') +attr(lon, 'variables') <- metadata +lat <- t(array(seq(-90, 90, length.out = num_lats), + dim = c(num_lats, num_lons))) +metadata <- list(lat = list(units = 'degrees_north')) +names(dim(lat)) <- c('x', 'y') +attr(lat, 'variables') <- metadata +tas2 <- CDORemap(tas, lon, lat, 'r100x50', 'bil') + +# An example of an interpolation from an irregular grid onto a gaussian grid +num_lats <- 25 +num_lons <- 50 +tas <- array(1:(10*num_lats*10*num_lons*10), + dim = c(10, num_lats, 10, num_lons)) +names(dim(tas)) <- c('a', 'j', 'b', 'i') +lon <- array(seq(0, 360 - 360/num_lons, length.out = num_lons), + dim = c(num_lons, num_lats)) +metadata <- list(lon = list(units = 'degrees_east')) +names(dim(lon)) <- c('i', 'j') +attr(lon, 'variables') <- metadata +lat <- t(array(seq(-90, 90, length.out = num_lats), + dim = c(num_lats, num_lons))) +metadata <- list(lat = list(units = 'degrees_north')) +names(dim(lat)) <- c('i', 'j') +attr(lat, 'variables') <- metadata +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil') + +# Again, the dimensions can be in any order +num_lats <- 25 +num_lons <- 50 +tas <- array(1:(10*num_lats*10*num_lons), + dim = c(10, num_lats, 10, num_lons)) +names(dim(tas)) <- c('a', 'j', 'b', 'i') +lon <- array(seq(0, 360 - 360/num_lons, length.out = num_lons), + dim = c(num_lons, num_lats)) +names(dim(lon)) <- c('i', 'j') +lat <- t(array(seq(-90, 90, length.out = num_lats), + dim = c(num_lats, num_lons))) +names(dim(lat)) <- c('i', 'j') +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil') +tas2 <- CDORemap(tas, lon, lat, 't17grid', 'bil', FALSE) +# It is ossible to specify an external NetCDF file as target grid reference +tas2 <- CDORemap(tas, lon, lat, 'external_file.nc', 'bil') +} +} +\author{ +History:\cr + 0.0 - 2017-01 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Original code. +} +\keyword{datagen} + diff --git a/man/ColorBar.Rd b/man/ColorBar.Rd new file mode 100644 index 0000000..71da02b --- /dev/null +++ b/man/ColorBar.Rd @@ -0,0 +1,188 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ColorBar.R +\name{ColorBar} +\alias{ColorBar} +\title{Draws a Color Bar} +\usage{ +ColorBar(brks = NULL, cols = NULL, vertical = TRUE, subsampleg = NULL, + bar_limits = NULL, var_limits = NULL, triangle_ends = NULL, + col_inf = NULL, col_sup = NULL, color_fun = clim.palette(), + plot = TRUE, draw_ticks = TRUE, draw_separators = FALSE, + triangle_ends_scale = 1, extra_labels = NULL, title = NULL, + title_scale = 1, label_scale = 1, tick_scale = 1, + extra_margin = rep(0, 4), label_digits = 4, ...) +} +\arguments{ +\item{brks}{Can be provided in two formats: +\itemize{ + \item{A single value with the number of breaks to be generated + automatically, between the minimum and maximum specified in 'var_limits' + (both inclusive). Hence the parameter 'var_limits' is mandatory if 'brks' + is provided with this format. If 'bar_limits' is additionally provided, + values only between 'bar_limits' will be generated. The higher the value + of 'brks', the smoother the plot will look.} + \item{A vector with the actual values of the desired breaks. Values will + be reordered by force to ascending order. If provided in this format, no + other parameters are required to generate/plot the colour bar.} +} + This parameter is optional if 'var_limits' is specified. If 'brks' not + specified but 'cols' is specified, it will take as value length(cols) + 1. + If 'cols' is not specified either, 'brks' will take 21 as value.} + +\item{cols}{Vector of length(brks) - 1 valid colour identifiers, for each +interval defined by the breaks. This parameter is optional and will be +filled in with a vector of length(brks) - 1 colours generated with the +function provided in 'color_fun' (\code{clim.colors} by default).\cr 'cols' +can have one additional colour at the beginning and/or at the end with the +aim to colour field values beyond the range of interest represented in the +colour bar. If any of these extra colours is provided, parameter +'triangle_ends' becomes mandatory in order to disambiguate which of the +ends the colours have been provided for.} + +\item{vertical}{TRUE/FALSE for vertical/horizontal colour bar +(disregarded if plot = FALSE).} + +\item{subsampleg}{The first of each subsampleg breaks will be ticked on the +colorbar. Takes by default an approximation of a value that yields a +readable tick arrangement (extreme breaks always ticked). If set to 0 or +lower, no labels are drawn. See the code of the function for details or +use 'extra_labels' for customized tick arrangements.} + +\item{bar_limits}{Vector of two numeric values with the extremes of the +range of values represented in the colour bar. If 'var_limits' go beyond +this interval, the drawing of triangle extremes is triggered at the +corresponding sides, painted in 'col_inf' and 'col_sup'. Either of them +can be set as NA and will then take as value the corresponding extreme in +'var_limits' (hence a triangle end won't be triggered for these sides). +Takes as default the extremes of 'brks' if available, else the same values +as 'var_limits'.} + +\item{var_limits}{Vector of two numeric values with the minimum and maximum +values of the field to represent. These are used to know whether to draw +triangle ends at the extremes of the colour bar and what colour to fill +them in with. If not specified, take the same value as the extremes of +'brks'. Hence the parameter 'brks' is mandatory if 'var_limits' is not +specified.} + +\item{triangle_ends}{Vector of two logical elements, indicating whether to +force the drawing of triangle ends at each of the extremes of the colour +bar. This choice is automatically made from the provided 'brks', +'bar_limits', 'var_limits', 'col_inf' and 'col_sup', but the behaviour +can be manually forced to draw or not to draw the triangle ends with this +parameter. If 'cols' is provided, 'col_inf' and 'col_sup' will take +priority over 'triangle_ends' when deciding whether to draw the triangle +ends or not.} + +\item{col_inf}{Colour to fill the inferior triangle end with. Useful if +specifying colours manually with parameter 'cols', to specify the colour +and to trigger the drawing of the lower extreme triangle, or if 'cols' is +not specified, to replace the colour automatically generated by ColorBar().} + +\item{col_sup}{Colour to fill the superior triangle end with. Useful if +specifying colours manually with parameter 'cols', to specify the colour +and to trigger the drawing of the upper extreme triangle, or if 'cols' is +not specified, to replace the colour automatically generated by ColorBar().} + +\item{color_fun}{Function to generate the colours of the color bar. Must +take an integer and must return as many colours. The returned colour vector +can have the attribute 'na_color', with a colour to draw NA values. This +parameter is set by default to clim.palette().} + +\item{plot}{Logical value indicating whether to only compute its breaks and +colours (FALSE) or to also draw it on the current device (TRUE).} + +\item{draw_ticks}{Whether to draw ticks for the labels along the colour bar +(TRUE) or not (FALSE). TRUE by default. Disregarded if 'plot = FALSE'.} + +\item{draw_separators}{Whether to draw black lines in the borders of each of +the colour rectancles of the colour bar (TRUE) or not (FALSE). FALSE by +default. Disregarded if 'plot = FALSE'.} + +\item{triangle_ends_scale}{Scale factor for the drawn triangle ends of the +colour bar, if drawn at all. Takes 1 by default (rectangle triangle +proportional to the thickness of the colour bar). Disregarded if +'plot = FALSE'.} + +\item{extra_labels}{Numeric vector of extra labels to draw along axis of +the colour bar. The number of provided decimals will be conserved. +Disregarded if 'plot = FALSE'.} + +\item{title}{Title to draw on top of the colour bar, most commonly with the +units of the represented field in the neighbour figures. Empty by default.} + +\item{title_scale}{Scale factor for the 'title' of the colour bar. +Takes 1 by default.} + +\item{label_scale}{Scale factor for the labels of the colour bar. +Takes 1 by default.} + +\item{tick_scale}{Scale factor for the length of the ticks of the labels +along the colour bar. Takes 1 by default.} + +\item{extra_margin}{Extra margins to be added around the colour bar, +in the format c(y1, x1, y2, x2). The units are margin lines. Takes +rep(0, 4) by default.} + +\item{label_digits}{Number of significant digits to be displayed in the +labels of the colour bar, usually to avoid too many decimal digits +overflowing the figure region. This does not have effect over the labels +provided in 'extra_labels'. Takes 4 by default.} + +\item{...}{Arguments to be passed to the method. Only accepts the following + graphical parameters:\cr adj ann ask bg bty cex.lab cex.main cex.sub cin + col.axis col.lab col.main col.sub cra crt csi cxy err family fg fig fin + font font.axis font.lab font.main font.sub lend lheight ljoin lmitre lty + lwd mai mex mfcol mfrow mfg mkh oma omd omi page pch pin plt pty smo srt + tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog.\cr For more +information about the parameters see `par`.} +} +\value{ +\item{brks}{ + Breaks used for splitting the range in intervals. +} +\item{cols}{ + Colours generated for each of the length(brks) - 1 intervals. + Always of length length(brks) - 1. +} +\item{col_inf}{ + Colour used to draw the lower triangle end in the colour + bar (NULL if not drawn at all). +} +\item{col_sup}{ + Colour used to draw the upper triangle end in the colour + bar (NULL if not drawn at all). +} +} +\description{ +Generates a color bar to use as colouring function for map plots and +optionally draws it (horizontally or vertically) to be added to map +multipanels or plots. It is possible to draw triangles at the ends of the +colour bar to represent values that go beyond the range of interest. A +number of options is provided to adjust the colours and the position and +size of the components. The drawn colour bar spans a whole figure region +and is compatible with figure layouts.\cr\cr +The generated colour bar consists of a set of breaks that define the +length(brks) - 1 intervals to classify each of the values in each of the +grid cells of a two-dimensional field. The corresponding grid cell of a +given value of the field will be coloured in function of the interval it +belongs to.\cr\cr +The only mandatory parameters are 'var_limits' or 'brks' (in its second +format, see below). +} +\examples{ +cols <- c("dodgerblue4", "dodgerblue1", "forestgreen", "yellowgreen", "white", + "white", "yellow", "orange", "red", "saddlebrown") +lims <- seq(-1, 1, 0.2) +ColorBar(lims, cols) +} +\author{ +History:\cr + 0.1 - 2012-04 (V. Guemas, \email{virginie.guemas@bsc.es}) - Original code\cr + 0.2 - 2013-04 (I. Andreu-Burillo, \email{isabel.andreu-burillo@bsc.es}) - Vert option\cr + 1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to CRAN\cr + 1.1 - 2013-09 (C. Prodhomme, \email{chloe.prodhomme@bsc.es}) - Add cex option\cr + 1.2 - 2016-08 (N. Manubens, \email{nicolau.manubens@bsc.es}) - New ColorBar\cr + (V. Torralba, \email{veronica.torralba@bsc.es}) +} +\keyword{hplot} + diff --git a/man/LeapYear.Rd b/man/LeapYear.Rd new file mode 100644 index 0000000..12b02b4 --- /dev/null +++ b/man/LeapYear.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/LeapYear.R +\name{LeapYear} +\alias{LeapYear} +\title{Checks Whether A Year Is Leap Year} +\usage{ +LeapYear(year) +} +\arguments{ +\item{year}{A numeric value indicating the year in the Gregorian calendar.} +} +\value{ +Boolean telling whether the year is a leap year or not. +} +\description{ +This function tells whether a year is a leap year or not. +} +\examples{ +print(LeapYear(1990)) +print(LeapYear(1991)) +print(LeapYear(1992)) +print(LeapYear(1993)) +} +\author{ +History:\cr +0.1 - 2011-03 (V. Guemas, \email{vguemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +} +\keyword{datagen} + diff --git a/man/Load.Rd b/man/Load.Rd new file mode 100644 index 0000000..c721e61 --- /dev/null +++ b/man/Load.Rd @@ -0,0 +1,886 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Load.R +\name{Load} +\alias{Load} +\title{Loads Experimental And Observational Data} +\usage{ +Load(var, exp = NULL, obs = NULL, sdates, nmember = NULL, + nmemberobs = NULL, nleadtime = NULL, leadtimemin = 1, + leadtimemax = NULL, storefreq = "monthly", sampleperiod = 1, + lonmin = 0, lonmax = 360, latmin = -90, latmax = 90, + output = "areave", method = "conservative", grid = NULL, + maskmod = vector("list", 15), maskobs = vector("list", 15), + configfile = NULL, varmin = NULL, varmax = NULL, silent = FALSE, + nprocs = NULL, dimnames = NULL, remapcells = 2, + path_glob_permissive = "partial") +} +\arguments{ +\item{var}{Short name of the variable to load. It should coincide with the +variable name inside the data files.\cr +E.g.: \code{var = 'tos'}, \code{var = 'tas'}, \code{var = 'prlr'}.\cr +In some cases, though, the path to the files contains twice or more times +the short name of the variable but the actual name of the variable inside +the data files is different. In these cases it may be convenient to provide +\code{var} with the name that appears in the file paths (see details on +parameters \code{exp} and \code{obs}).} + +\item{exp}{Parameter to specify which experimental datasets to load data +from.\cr +It can take two formats: a list of lists or a vector of character strings. +Each format will trigger a different mechanism of locating the requested +datasets.\cr +The first format is adequate when loading data you'll only load once or +occasionally. The second format is targeted to avoid providing repeatedly +the information on a certain dataset but is more complex to use.\cr\cr +IMPORTANT: Place first the experiment with the largest number of members +and, if possible, with the largest number of leadtimes. If not possible, +the arguments 'nmember' and/or 'nleadtime' should be filled to not miss +any member or leadtime.\cr +If 'exp' is not specified or set to NULL, observational data is loaded for +each start-date as far as 'leadtimemax'. If 'leadtimemax' is not provided, +\code{Load()} will retrieve data of a period of time as long as the time +period between the first specified start date and the current date.\cr\cr +List of lists:\cr +A list of lists where each sub-list contains information on the location +and format of the data files of the dataset to load.\cr +Each sub-list can have the following components: + \itemize{ + \item{'name': A character string to identify the dataset. Optional.} + \item{'path': A character string with the pattern of the path to the + files of the dataset. This pattern can be built up making use of some + special tags that \code{Load()} will replace with the appropriate + values to find the dataset files. The allowed tags are $START_DATE$, + $YEAR$, $MONTH$, $DAY$, $MEMBER_NUMBER$, $STORE_FREQ$, $VAR_NAME$, + $EXP_NAME$ (only for experimental datasets), $OBS_NAME$ (only for + observational datasets) and $SUFFIX$\cr + Example: /path/to/$EXP_NAME$/postprocessed/$VAR_NAME$/\cr + $VAR_NAME$_$START_DATE$.nc\cr + If 'path' is not specified and 'name' is specified, the dataset + information will be fetched with the same mechanism as when using + the vector of character strings (read below). + } + \item{'nc_var_name': Character string with the actual variable name + to look for inside the dataset files. Optional. Takes, by default, + the same value as the parameter 'var'. + } + \item{'suffix': Wildcard character string that can be used to build + the 'path' of the dataset. It can be accessed with the tag $SUFFIX$. + Optional. Takes '' by default. + } + \item{'var_min': Important: Character string. Minimum value beyond + which read values will be deactivated to NA. Optional. No deactivation + is performed by default. + } + \item{'var_max': Important: Character string. Maximum value beyond + which read values will be deactivated to NA. Optional. No deactivation + is performed by default. + } + } +The tag $START_DATES$ will be replaced with all the starting dates +specified in 'sdates'. $YEAR$, $MONTH$ and $DAY$ will take a value for each +iteration over 'sdates', simply these are the same as $START_DATE$ but +split in parts.\cr +$MEMBER_NUMBER$ will be replaced by a character string with each member +number, from 1 to the value specified in the parameter 'nmember' (in +experimental datasets) or in 'nmemberobs' (in observational datasets). It +will range from '01' to 'N' or '0N' if N < 10.\cr +$STORE_FREQ$ will take the value specified in the parameter 'storefreq' +('monthly' or 'daily').\cr +$VAR_NAME$ will take the value specified in the parameter 'var'.\cr +$EXP_NAME$ will take the value specified in each component of the parameter +'exp' in the sub-component 'name'.\cr +$OBS_NAME$ will take the value specified in each component of the parameter +'obs' in the sub-component 'obs.\cr +$SUFFIX$ will take the value specified in each component of the parameters +'exp' and 'obs' in the sub-component 'suffix'.\cr +Example: +\preformatted{ +list( + list( + name = 'experimentA', + path = file.path('/path/to/$DATASET_NAME$/$STORE_FREQ$', + '$VAR_NAME$$SUFFIX$', + '$VAR_NAME$_$START_DATE$.nc'), + nc_var_name = '$VAR_NAME$', + suffix = '_3hourly', + var_min = '-1e19', + var_max = '1e19' + ) +) +} +This will make \code{Load()} look for, for instance, the following paths, +if 'sdates' is c('19901101', '19951101', '20001101'):\cr + /path/to/experimentA/monthly_mean/tas_3hourly/tas_19901101.nc\cr + /path/to/experimentA/monthly_mean/tas_3hourly/tas_19951101.nc\cr + /path/to/experimentA/monthly_mean/tas_3hourly/tas_20001101.nc\cr\cr +Vector of character strings: +To avoid specifying constantly the same information to load the same +datasets, a vector with only the names of the datasets to load can be +specified.\cr +\code{Load()} will then look for the information in a configuration file +whose path must be specified in the parameter 'configfile'.\cr +Check \code{?ConfigFileCreate}, \code{ConfigFileOpen}, +\code{ConfigEditEntry} & co. to learn how to create a new configuration +file and how to add the information there.\cr +Example: c('experimentA', 'experimentB')} + +\item{obs}{Argument with the same format as parameter 'exp'. See details on +parameter 'exp'.\cr +If 'obs' is not specified or set to NULL, no observational data is loaded.\cr} + +\item{sdates}{Vector of starting dates of the experimental runs to be loaded +following the pattern 'YYYYMMDD'.\cr +This argument is mandatory.\cr +E.g. c('19601101', '19651101', '19701101')} + +\item{nmember}{Vector with the numbers of members to load from the specified +experimental datasets in 'exp'.\cr +If not specified, the automatically detected number of members of the +first experimental dataset is detected and replied to all the experimental +datasets.\cr +If a single value is specified it is replied to all the experimental +datasets.\cr +Data for each member is fetched in the file system. If not found is +filled with NA values.\cr +An NA value in the 'nmember' list is interpreted as "fetch as many members +of each experimental dataset as the number of members of the first +experimental dataset".\cr +Note: It is recommended to specify the number of members of the first +experimental dataset if it is stored in file per member format because +there are known issues in the automatic detection of members if the path +to the dataset in the configuration file contains Shell Globbing wildcards +such as '*'.\cr +E.g., c(4, 9)} + +\item{nmemberobs}{Vector with the numbers of members to load from the +specified observational datasets in 'obs'.\cr +If not specified, the automatically detected number of members of the +first observational dataset is detected and replied to all the +observational datasets.\cr +If a single value is specified it is replied to all the observational +datasets.\cr +Data for each member is fetched in the file system. If not found is +filled with NA values.\cr +An NA value in the 'nmemberobs' list is interpreted as "fetch as many +members of each observational dataset as the number of members of the +first observational dataset".\cr +Note: It is recommended to specify the number of members of the first +observational dataset if it is stored in file per member format because +there are known issues in the automatic detection of members if the path +to the dataset in the configuration file contains Shell Globbing wildcards +such as '*'.\cr +E.g., c(1, 5)} + +\item{nleadtime}{Deprecated. See parameter 'leadtimemax'.} + +\item{leadtimemin}{Only lead-times higher or equal to 'leadtimemin' are +loaded. Takes by default value 1.} + +\item{leadtimemax}{Only lead-times lower or equal to 'leadtimemax' are loaded. +Takes by default the number of lead-times of the first experimental +dataset in 'exp'.\cr +If 'exp' is NULL this argument won't have any effect +(see \code{?Load} description).} + +\item{storefreq}{Frequency at which the data to be loaded is stored in the +file system. Can take values 'monthly' or 'daily'.\cr +By default it takes 'monthly'.\cr +Note: Data stored in other frequencies with a period which is divisible by +a month can be loaded with a proper use of 'storefreq' and 'sampleperiod' +parameters. It can also be loaded if the period is divisible by a day and +the observational datasets are stored in a file per dataset format or +'obs' is empty.} + +\item{sampleperiod}{To load only a subset between 'leadtimemin' and +'leadtimemax' with the period of subsampling 'sampleperiod'.\cr +Takes by default value 1 (all lead-times are loaded).\cr +See 'storefreq' for more information.} + +\item{lonmin}{If a 2-dimensional variable is loaded, values at longitudes +lower than 'lonmin' aren't loaded.\cr +Must take a value in the range [-360, 360] (if negative longitudes are +found in the data files these are translated to this range).\cr +It is set to 0 if not specified.\cr +If 'lonmin' > 'lonmax', data across Greenwich is loaded.} + +\item{lonmax}{If a 2-dimensional variable is loaded, values at longitudes +higher than 'lonmax' aren't loaded.\cr +Must take a value in the range [-360, 360] (if negative longitudes are +found in the data files these are translated to this range).\cr +It is set to 360 if not specified.\cr +If 'lonmin' > 'lonmax', data across Greenwich is loaded.} + +\item{latmin}{If a 2-dimensional variable is loaded, values at latitudes +lower than 'latmin' aren't loaded.\cr +Must take a value in the range [-90, 90].\cr +It is set to -90 if not specified.} + +\item{latmax}{If a 2-dimensional variable is loaded, values at latitudes +higher than 'latmax' aren't loaded.\cr +Must take a value in the range [-90, 90].\cr +It is set to 90 if not specified.} + +\item{output}{This parameter determines the format in which the data is +arranged in the output arrays.\cr +Can take values 'areave', 'lon', 'lat', 'lonlat'.\cr + \itemize{ + \item{'areave': Time series of area-averaged variables over the specified domain.} + \item{'lon': Time series of meridional averages as a function of longitudes.} + \item{'lat': Time series of zonal averages as a function of latitudes.} + \item{'lonlat': Time series of 2d fields.} +} +Takes by default the value 'areave'. If the variable specified in 'var' is +a global mean, this parameter is forced to 'areave'.\cr +All the loaded data is interpolated into the grid of the first experimental +dataset except if 'areave' is selected. In that case the area averages are +computed on each dataset original grid. A common grid different than the +first experiment's can be specified through the parameter 'grid'. If 'grid' +is specified when selecting 'areave' output type, all the loaded data is +interpolated into the specified grid before calculating the area averages.} + +\item{method}{This parameter determines the interpolation method to be used +when regridding data (see 'output'). Can take values 'bilinear', 'bicubic', +'conservative', 'distance-weighted'.\cr +See \code{remapcells} for advanced adjustments.\cr +Takes by default the value 'conservative'.} + +\item{grid}{A common grid can be specified through the parameter 'grid' when +loading 2-dimensional data. Data is then interpolated onto this grid +whichever 'output' type is specified. If the selected output type is +'areave' and a 'grid' is specified, the area averages are calculated after +interpolating to the specified grid.\cr +If not specified and the selected output type is 'lon', 'lat' or 'lonlat', +this parameter takes as default value the grid of the first experimental +dataset, which is read automatically from the source files.\cr +The grid must be supported by 'cdo' tools. Now only supported: rNXxNY +or tTRgrid.\cr +Both rNXxNY and tRESgrid yield rectangular regular grids. rNXxNY yields +grids that are evenly spaced in longitudes and latitudes (in degrees). +tRESgrid refers to a grid generated with series of spherical harmonics +truncated at the RESth harmonic. However these spectral grids are usually +associated to a gaussian grid, the latitudes of which are spaced with a +Gaussian quadrature (not evenly spaced in degrees). The pattern tRESgrid +will yield a gaussian grid.\cr +E.g., 'r96x72' +Advanced: If the output type is 'lon', 'lat' or 'lonlat' and no common +grid is specified, the grid of the first experimental or observational +dataset is detected and all data is then interpolated onto this grid. +If the first experimental or observational dataset's data is found shifted +along the longitudes (i.e., there's no value at the longitude 0 but at a +longitude close to it), the data is re-interpolated to suppress the shift. +This has to be done in order to make sure all the data from all the +datasets is properly aligned along longitudes, as there's no option so far +in \code{Load} to specify grids starting at longitudes other than 0. +This issue doesn't affect when loading in 'areave' mode without a common +grid, the data is not re-interpolated in that case.} + +\item{maskmod}{List of masks to be applied to the data of each experimental +dataset respectively, if a 2-dimensional variable is specified in 'var'.\cr +Each mask can be defined in 2 formats:\cr +a) a matrix with dimensions c(longitudes, latitudes).\cr +b) a list with the components 'path' and, optionally, 'nc_var_name'.\cr +In the format a), the matrix must have the same size as the common grid +or with the same size as the grid of the corresponding experimental dataset +if 'areave' output type is specified and no common 'grid' is specified.\cr +In the format b), the component 'path' must be a character string with the +path to a NetCDF mask file, also in the common grid or in the grid of the +corresponding dataset if 'areave' output type is specified and no common +'grid' is specified. If the mask file contains only a single variable, +there's no need to specify the component 'nc_var_name'. Otherwise it must +be a character string with the name of the variable inside the mask file +that contains the mask values. This variable must be defined only over 2 +dimensions with length greater or equal to 1.\cr +Whichever the mask format, a value of 1 at a point of the mask keeps the +original value at that point whereas a value of 0 disables it (replaces +by a NA value).\cr +By default all values are kept (all ones).\cr +The longitudes and latitudes in the matrix must be in the same order as in +the common grid or as in the original grid of the corresponding dataset +when loading in 'areave' mode. You can find out the order of the longitudes +and latitudes of a file with 'cdo griddes'.\cr +Note that in a common CDO grid defined with the patterns 'tgrid' or +'rx' the latitudes and latitudes are ordered, by definition, from +-90 to 90 and from 0 to 360, respectively.\cr +If you are loading maps ('lonlat', 'lon' or 'lat' output types) all the +data will be interpolated onto the common 'grid'. If you want to specify +a mask, you will have to provide it already interpolated onto the common +grid (you may use 'cdo' libraries for this purpose). It is not usual to +apply different masks on experimental datasets on the same grid, so all +the experiment masks are expected to be the same.\cr +Warning: When loading maps, any masks defined for the observational data +will be ignored to make sure the same mask is applied to the experimental +and observational data.\cr +Warning: list() compulsory even if loading 1 experimental dataset only!\cr +E.g., list(array(1, dim = c(num_lons, num_lats)))} + +\item{maskobs}{See help on parameter 'maskmod'.} + +\item{configfile}{Path to the s2dverification configuration file from which +to retrieve information on location in file system (and other) of datasets.\cr +If not specified, the configuration file used at BSC-ES will be used +(it is included in the package).\cr +Check the BSC's configuration file or a template of configuration file in +the folder 'inst/config' in the package.\cr +Check further information on the configuration file mechanism in +\code{ConfigFileOpen()}.} + +\item{varmin}{Loaded experimental and observational data values smaller +than 'varmin' will be disabled (replaced by NA values).\cr +By default no deactivation is performed.} + +\item{varmax}{Loaded experimental and observational data values greater +than 'varmax' will be disabled (replaced by NA values).\cr +By default no deactivation is performed.} + +\item{silent}{Parameter to show (FALSE) or hide (TRUE) information messages.\cr +Warnings will be displayed even if 'silent' is set to TRUE.\cr +Takes by default the value 'FALSE'.} + +\item{nprocs}{Number of parallel processes created to perform the fetch +and computation of data.\cr +These processes will use shared memory in the processor in which Load() +is launched.\cr +By default the number of logical cores in the machine will be detected +and as many processes as logical cores there are will be created.\cr +A value of 1 won't create parallel processes.\cr +When running in multiple processes, if an error occurs in any of the +processes, a crash message appears in the R session of the original +process but no detail is given about the error. A value of 1 will display +all error messages in the original and only R session.\cr +Note: the parallel process create other blocking processes each time they +need to compute an interpolation via 'cdo'.} + +\item{dimnames}{Named list where the name of each element is a generic +name of the expected dimensions inside the NetCDF files. These generic +names are 'lon', 'lat' and 'member'. 'time' is not needed because it's +detected automatically by discard.\cr +The value associated to each name is the actual dimension name in the +NetCDF file.\cr +The variables in the file that contain the longitudes and latitudes of +the data (if the data is a 2-dimensional variable) must have the same +name as the longitude and latitude dimensions.\cr +By default, these names are 'longitude', 'latitude' and 'ensemble. If any +of those is defined in the 'dimnames' parameter, it takes priority and +overwrites the default value. +E.g., list(lon = 'x', lat = 'y') +In that example, the dimension 'member' will take the default value 'ensemble'.} + +\item{remapcells}{When loading a 2-dimensional variable, spatial subsets can +be requested via \code{lonmin}, \code{lonmax}, \code{latmin} and +\code{latmax}. When \code{Load()} obtains the subset it is then +interpolated if needed with the method specified in \code{method}.\cr +The result of this interpolation can vary if the values surrounding the +spatial subset are not present. To better control this process, the width +in number of grid cells of the surrounding area to be taken into account +can be specified with \code{remapcells}. A value of 0 will take into +account no additional cells but will generate less traffic between the +storage and the R processes that load data.\cr +A value beyond the limits in the data files will be automatically runcated +to the actual limit.\cr +The default value is 2.} + +\item{path_glob_permissive}{In some cases, when specifying a path pattern +(either in the parameters 'exp'/'obs' or in a configuration file) one can +specify path patterns that contain shell globbing expressions. Too much +freedom in putting globbing expressions in the path patterns can be +dangerous and make \code{Load()} find a file in the file system for a +start date for a dataset that really does not belong to that dataset. +For example, if the file system contains two directories for two different +experiments that share a part of their path and the path pattern contains +globbing expressions: + /experiments/model1/expA/monthly_mean/tos/tos_19901101.nc + /experiments/model2/expA/monthly_mean/tos/tos_19951101.nc +And the path pattern is used as in the example right below to load data of +only the experiment 'expA' of the model 'model1' for the starting dates +'19901101' and '19951101', \code{Load()} will undesiredly yield data for +both starting dates, even if in fact there is data only for the +first one:\cr + \code{ +expA <- list(path = file.path('/experiments/*/expA/monthly_mean/$VAR_NAME$', + '$VAR_NAME$_$START_DATE$.nc') +data <- Load('tos', list(expA), NULL, c('19901101', '19951101')) + } +To avoid these situations, the parameter \code{path_glob_permissive} is +set by default to \code{'partial'}, which forces \code{Load()} to replace +all the globbing expressions of a path pattern of a data set by fixed +values taken from the path of the first found file for each data set, up +to the folder right before the final files (globbing expressions in the +file name will not be replaced, only those in the path to the file). +Replacement of globbing expressions in the file name can also be triggered +by setting \code{path_glob_permissive} to \code{FALSE} or \code{'no'}. If +needed to keep all globbing expressions, \code{path_glob_permissive} can +be set to \code{TRUE} or \code{'yes'}.} +} +\value{ +\code{Load()} returns a named list following a structure similar to the +used in the package 'downscaleR'.\cr +The components are the following: + \itemize{ + \item{ + 'mod' is the array that contains the experimental data. It has the + attribute 'dimensions' associated to a vector of strings with the + labels of each dimension of the array, in order. The order of the + latitudes is always forced to be from 90 to -90 whereas the order of + the longitudes is kept as in the original files (if possible). The + longitude values provided in \code{lon} lower than 0 are added 360 + (but still kept in the original order). In some cases, however, if + multiple data sets are loaded in longitude-latitude mode, the + longitudes (and also the data arrays in \code{mod} and \code{obs}) are + re-ordered afterwards by \code{Load()} to range from 0 to 360; a + warning is given in such cases. The longitude and latitude of the + center of the grid cell that corresponds to the value [j, i] in 'mod' + (along the dimensions latitude and longitude, respectively) can be + found in the outputs \code{lon}[i] and \code{lat}[j] + } + \item{'obs' is the array that contains the observational data. The + same documentation of parameter 'mod' applies to this parameter.} + \item{'lat' and 'lon' are the latitudes and longitudes of the centers of + the cells of the grid the data is interpolated into (0 if the loaded + variable is a global mean or the output is an area average).\cr + Both have the attribute 'cdo_grid_des' associated with a character + string with the name of the common grid of the data, following the CDO + naming conventions for grids.\cr + 'lon' has the attributes 'first_lon' and 'last_lon', with the first + and last longitude values found in the region defined by 'lonmin' and + 'lonmax'. 'lat' has also the equivalent attributes 'first_lat' and + 'last_lat'.\cr + 'lon' has also the attribute 'data_across_gw' which tells whether the + requested region via 'lonmin', 'lonmax', 'latmin', 'latmax' goes across + the Greenwich meridian. As explained in the documentation of the + parameter 'mod', the loaded data array is kept in the same order as in + the original files when possible: this means that, in some cases, even + if the data goes across the Greenwich, the data array may not go + across the Greenwich. The attribute 'array_across_gw' tells whether + the array actually goes across the Greenwich. E.g: The longitudes in + the data files are defined to be from 0 to 360. The requested + longitudes are from -80 to 40. The original order is kept, hence the + longitudes in the array will be ordered as follows: + 0, ..., 40, 280, ..., 360. In that case, 'data_across_gw' will be TRUE + and 'array_across_gw' will be FALSE.\cr + The attribute 'projection' is kept for compatibility with 'downscaleR'. + } + \item{'Variable' has the following components: + \itemize{ + \item{'varName', with the short name of the loaded variable as + specified in the parameter 'var'. + } + \item{'level', with information on the pressure level of the + variable. Is kept to NULL by now. + } + } + And the following attributes: + \itemize{ + \item{'is_standard', kept for compatibility with 'downscaleR', + tells if a dataset has been homogenized to standards with + 'downscaleR' catalogs. + } + \item{'units', a character string with the units of measure of the + variable, as found in the source files. + } + \item{'longname', a character string with the long name of the + variable, as found in the source files. + } + \item{'daily_agg_cellfun', 'monthly_agg_cellfun', + 'verification_time', kept for compatibility with 'downscaleR'. + } + } + } + \item{'Datasets' has the following components: + \itemize{ + \item{'exp', a named list where the names are the identifying + character strings of each experiment in 'exp', each associated to + a list with the following components: + \itemize{ + \item{'members', a list with the names of the members of the dataset.} + \item{'source', a path or URL to the source of the dataset.} + } + } + \item{'obs', similar to 'exp' but for observational datasets.} + } + } + \item{'Dates', with the follwing components: + \itemize{ + \item{'start', an array of dimensions (sdate, time) with the POSIX + initial date of each forecast time of each starting date. + } + \item{'end', an array of dimensions (sdate, time) with the POSIX + final date of each forecast time of each starting date. + } + } + } + \item{'InitializationDates', a vector of starting dates as specified in + 'sdates', in POSIX format. + } + \item{'when', a time stamp of the date the \code{Load()} call to obtain + the data was issued. + } + \item{'source_files', a vector of character strings with complete paths + to all the found files involved in the \code{Load()} call. + } + \item{'not_found_files', a vector of character strings with complete + paths to not found files involved in the \code{Load()} call. + } + } +} +\description{ +This function loads monthly or daily data from a set of specified +experimental datasets together with data that date-corresponds from a set +of specified observational datasets. See parameters 'storefreq', +'sampleperiod', 'exp' and 'obs'.\cr\cr +A set of starting dates is specified through the parameter 'sdates'. Data of +each starting date is loaded for each model. +\code{Load()} arranges the data in two arrays with a similar format both +with the following dimensions: + \enumerate{ + \item{The number of experimental datasets determined by the user through + the argument 'exp' (for the experimental data array) or the number of + observational datasets available for validation (for the observational + array) determined as well by the user through the argument 'obs'.} + \item{The greatest number of members across all experiments (in the + experimental data array) or across all observational datasets (in the + observational data array).} + \item{The number of starting dates determined by the user through the + 'sdates' argument.} + \item{The greatest number of lead-times.} + \item{The number of latitudes of the selected zone.} + \item{The number of longitudes of the selected zone.} + } +Dimensions 5 and 6 are optional and their presence depends on the type of +the specified variable (global mean or 2-dimensional) and on the selected +output type (area averaged time series, latitude averaged time series, +longitude averaged time series or 2-dimensional time series).\cr +In the case of loading an area average the dimensions of the arrays will be +only the first 4.\cr\cr +Only a specified variable is loaded from each experiment at each starting +date. See parameter 'var'.\cr +Afterwards, observational data that matches every starting date and lead-time +of every experimental dataset is fetched in the file system (so, if two +predictions at two different start dates overlap, some observational values +will be loaded and kept in memory more than once).\cr +If no data is found in the file system for an experimental or observational +array point it is filled with an NA value.\cr\cr +If the specified output is 2-dimensional or latitude- or longitude-averaged +time series all the data is interpolated into a common grid. If the +specified output type is area averaged time series the data is averaged on +the individual grid of each dataset but can also be averaged after +interpolating into a common grid. See parameters 'grid' and 'method'.\cr +Once the two arrays are filled by calling this function, other functions in +the s2dverification package that receive as inputs data formatted in this +data structure can be executed (e.g: \code{Clim()} to compute climatologies, +\code{Ano()} to compute anomalies, ...).\cr\cr +Load() has many additional parameters to disable values and trim dimensions +of selected variable, even masks can be applied to 2-dimensional variables. +See parameters 'nmember', 'nmemberobs', 'nleadtime', 'leadtimemin', +'leadtimemax', 'sampleperiod', 'lonmin', 'lonmax', 'latmin', 'latmax', +'maskmod', 'maskobs', 'varmin', 'varmax'.\cr\cr +The parameters 'exp' and 'obs' can take various forms. The most direct form +is a list of lists, where each sub-list has the component 'path' associated +to a character string with a pattern of the path to the files of a dataset +to be loaded. These patterns can contain wildcards and tags that will be +replaced automatically by \code{Load()} with the specified starting dates, +member numbers, variable name, etc.\cr +See parameter 'exp' or 'obs' for details.\cr\cr +Only NetCDF files are supported. OPeNDAP URLs to NetCDF files are also +supported.\cr +\code{Load()} can load 2-dimensional or global mean variables in any of the +following formats: + \itemize{ + \item{experiments: + \itemize{ + \item{file per ensemble per starting date + (YYYY, MM and DD somewhere in the path)} + \item{file per member per starting date + (YYYY, MM, DD and MemberNumber somewhere in the path. Ensemble + experiments with different numbers of members can be loaded in + a single \code{Load()} call.)} + } + (YYYY, MM and DD specify the starting dates of the predictions) + } + \item{observations: + \itemize{ + \item{file per ensemble per month + (YYYY and MM somewhere in the path)} + \item{file per member per month + (YYYY, MM and MemberNumber somewhere in the path, obs with different + numbers of members supported)} + \item{file per dataset (No constraints in the path but the time axes + in the file have to be properly defined)} + } + (YYYY and MM correspond to the actual month data in the file) + } + } +In all the formats the data can be stored in a daily or monthly frequency, +or a multiple of these (see parameters 'storefreq' and 'sampleperiod').\cr +All the data files must contain the target variable defined over time and +potentially over members, latitude and longitude dimensions in any order, +time being the record dimension.\cr +In the case of a two-dimensional variable, the variables longitude and +latitude must be defined inside the data file too and must have the same +names as the dimension for longitudes and latitudes respectively.\cr +The names of these dimensions (and longitude and latitude variables) and the +name for the members dimension are expected to be 'longitude', 'latitude' +and 'ensemble' respectively. However, these names can be adjusted with the +parameter 'dimnames' or can be configured in the configuration file (read +below in parameters 'exp', 'obs' or see \code{?ConfigFileOpen} +for more information.\cr +All the data files are expected to have numeric values representable with +32 bits. Be aware when choosing the fill values or infinite values in the +datasets to load.\cr\cr +The Load() function returns a named list following a structure similar to +the used in the package 'downscaleR'.\cr +The components are the following: + \itemize{ + \item{'mod' is the array that contains the experimental data. It has the + attribute 'dimensions' associated to a vector of strings with the labels + of each dimension of the array, in order.} + \item{'obs' is the array that contains the observational data. It has + the attribute 'dimensions' associated to a vector of strings with the + labels of each dimension of the array, in order.} + \item{'obs' is the array that contains the observational data.} + \item{'lat' and 'lon' are the latitudes and longitudes of the grid into + which the data is interpolated (0 if the loaded variable is a global + mean or the output is an area average).\cr + Both have the attribute 'cdo_grid_des' associated with a character + string with the name of the common grid of the data, following the CDO + naming conventions for grids.\cr + The attribute 'projection' is kept for compatibility with 'downscaleR'. + } + \item{'Variable' has the following components: + \itemize{ + \item{'varName', with the short name of the loaded variable as + specified in the parameter 'var'.} + \item{'level', with information on the pressure level of the variable. + Is kept to NULL by now.} + } + And the following attributes: + \itemize{ + \item{'is_standard', kept for compatibility with 'downscaleR', + tells if a dataset has been homogenized to standards with + 'downscaleR' catalogs.} + \item{'units', a character string with the units of measure of the + variable, as found in the source files.} + \item{'longname', a character string with the long name of the + variable, as found in the source files.} + \item{'daily_agg_cellfun', 'monthly_agg_cellfun', 'verification_time', + kept for compatibility with 'downscaleR'.} + } + } + \item{'Datasets' has the following components: + \itemize{ + \item{'exp', a named list where the names are the identifying + character strings of each experiment in 'exp', each associated to a + list with the following components: + \itemize{ + \item{'members', a list with the names of the members of the + dataset.} + \item{'source', a path or URL to the source of the dataset.} + } + } + \item{'obs', similar to 'exp' but for observational datasets.} + } + } + \item{'Dates', with the follwing components: + \itemize{ + \item{'start', an array of dimensions (sdate, time) with the POSIX + initial date of each forecast time of each starting date.} + \item{'end', an array of dimensions (sdate, time) with the POSIX + final date of each forecast time of each starting date.} + } + } + \item{'InitializationDates', a vector of starting dates as specified in + 'sdates', in POSIX format.} + \item{'when', a time stamp of the date the \code{Load()} call to obtain + the data was issued.} + \item{'source_files', a vector of character strings with complete paths + to all the found files involved in the \code{Load()} call.} + \item{'not_found_files', a vector of character strings with complete + paths to not found files involved in the \code{Load()} call.} + } +} +\details{ +The two output matrices have between 2 and 6 dimensions:\cr + \enumerate{ + \item{Number of experimental/observational datasets.} + \item{Number of members.} + \item{Number of startdates.} + \item{Number of leadtimes.} + \item{Number of latitudes (optional).} + \item{Number of longitudes (optional).} + } +but the two matrices have the same number of dimensions and only the first +two dimensions can have different lengths depending on the input arguments. +For a detailed explanation of the process, read the documentation attached +to the package or check the comments in the code. +} +\examples{ +# Let's assume we want to perform verification with data of a variable +# called 'tos' from a model called 'model' and observed data coming from +# an observational dataset called 'observation'. +# +# The model was run in the context of an experiment named 'experiment'. +# It simulated from 1st November in 1985, 1990, 1995, 2000 and 2005 for a +# period of 5 years time from each starting date. 5 different sets of +# initial conditions were used so an ensemble of 5 members was generated +# for each starting date. +# The model generated values for the variables 'tos' and 'tas' in a +# 3-hourly frequency but, after some initial post-processing, it was +# averaged over every month. +# The resulting monthly average series were stored in a file for each +# starting date for each variable with the data of the 5 ensemble members. +# The resulting directory tree was the following: +# model +# |--> experiment +# |--> monthly_mean +# |--> tos_3hourly +# | |--> tos_19851101.nc +# | |--> tos_19901101.nc +# | . +# | . +# | |--> tos_20051101.nc +# |--> tas_3hourly +# |--> tas_19851101.nc +# |--> tas_19901101.nc +# . +# . +# |--> tas_20051101.nc +# +# The observation recorded values of 'tos' and 'tas' at each day of the +# month over that period but was also averaged over months and stored in +# a file per month. The directory tree was the following: +# observation +# |--> monthly_mean +# |--> tos +# | |--> tos_198511.nc +# | |--> tos_198512.nc +# | |--> tos_198601.nc +# | . +# | . +# | |--> tos_201010.nc +# |--> tas +# |--> tas_198511.nc +# |--> tas_198512.nc +# |--> tas_198601.nc +# . +# . +# |--> tas_201010.nc +# +# The model data is stored in a file-per-startdate fashion and the +# observational data is stored in a file-per-month, and both are stored in +# a monthly frequency. The file format is NetCDF. +# Hence all the data is supported by Load() (see details and other supported +# conventions in ?Load) but first we need to configure it properly. +# +# These data files are included in the package (in the 'sample_data' folder), +# only for the variable 'tos'. They have been interpolated to a very low +# resolution grid so as to make it on CRAN. +# The original grid names (following CDO conventions) for experimental and +# observational data were 't106grid' and 'r180x89' respectively. The final +# resolutions are 'r20x10' and 'r16x8' respectively. +# The experimental data comes from the decadal climate prediction experiment +# run at IC3 in the context of the CMIP5 project. Its name within IC3 local +# database is 'i00k'. +# The observational dataset used for verification is the 'ERSST' +# observational dataset. +# +# The next two examples are equivalent and show how to load the variable +# 'tos' from these sample datasets, the first providing lists of lists to +# the parameters 'exp' and 'obs' (see documentation on these parameters) and +# the second providing vectors of character strings, hence using a +# configuration file. +# +# The code is not run because it dispatches system calls to 'cdo' which is +# not allowed in the examples as per CRAN policies. You can run it on your +# system though. +# Instead, the code in 'dontshow' is run, which loads the equivalent +# already processed data in R. +# +# Example 1: Providing lists of lists to 'exp' and 'obs': +# + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +exp <- list( + name = 'experiment', + path = file.path(data_path, 'model/$EXP_NAME$/monthly_mean', + '$VAR_NAME$_3hourly/$VAR_NAME$_$START_DATES$.nc') + ) +obs <- list( + name = 'observation', + path = file.path(data_path, 'observation/$OBS_NAME$/monthly_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(exp), list(obs), startDates, + output = 'areave', latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } +# +# Example 2: Providing vectors of character strings to 'exp' and 'obs' +# and using a configuration file. +# +# The configuration file 'sample.conf' that we will create in the example +# has the proper entries to load these (see ?LoadConfigFile for details on +# writing a configuration file). +# + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + output = 'areave', latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) +# +# Example 2: providing character strings in 'exp' and 'obs', and providing +# a configuration file. +# The configuration file 'sample.conf' that we will create in the example +# has the proper entries to load these (see ?LoadConfigFile for details on +# writing a configuration file). +# +configfile <- paste0(tempdir(), '/sample.conf') +ConfigFileCreate(configfile, confirm = FALSE) +c <- ConfigFileOpen(configfile) +c <- ConfigEditDefinition(c, 'DEFAULT_VAR_MIN', '-1e19', confirm = FALSE) +c <- ConfigEditDefinition(c, 'DEFAULT_VAR_MAX', '1e19', confirm = FALSE) +data_path <- system.file('sample_data', package = 's2dverification') +exp_data_path <- paste0(data_path, '/model/$EXP_NAME$/') +obs_data_path <- paste0(data_path, '/$OBS_NAME$/') +c <- ConfigAddEntry(c, 'experiments', dataset_name = 'experiment', + var_name = 'tos', main_path = exp_data_path, + file_path = '$STORE_FREQ$_mean/$VAR_NAME$_3hourly/$VAR_NAME$_$START_DATE$.nc') +c <- ConfigAddEntry(c, 'observations', dataset_name = 'observation', + var_name = 'tos', main_path = obs_data_path, + file_path = '$STORE_FREQ$_mean/$VAR_NAME$/$VAR_NAME$_$YEAR$$MONTH$.nc') +ConfigFileSave(c, configfile, confirm = FALSE) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', c('experiment'), c('observation'), startDates, + output = 'areave', latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40, configfile = configfile) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + output = 'areave', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } +} +\author{ +History:\cr +0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@bsc.es}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to CRAN\cr +1.2 - 2015-02 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Generalisation + parallelisation\cr +1.3 - 2015-07 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Improvements related to configuration file mechanism\cr +1.4 - 2016-01 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Added subsetting capabilities +} +\keyword{datagen} + diff --git a/man/Plot2VarsVsLTime.Rd b/man/Plot2VarsVsLTime.Rd new file mode 100644 index 0000000..8ba44e4 --- /dev/null +++ b/man/Plot2VarsVsLTime.Rd @@ -0,0 +1,123 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Plot2VarsVsLTime.R +\name{Plot2VarsVsLTime} +\alias{Plot2VarsVsLTime} +\title{Plot Two Scores With Confidence Intervals In A Common Plot} +\usage{ +Plot2VarsVsLTime(var1, var2, toptitle = "", ytitle = "", monini = 1, + freq = 12, nticks = NULL, limits = NULL, listexp = c("exp1", "exp2", + "exp3"), listvars = c("var1", "var2"), biglab = FALSE, hlines = NULL, + leg = TRUE, siglev = FALSE, sizetit = 1, show_conf = TRUE, + fileout = "output_plot2varsvsltime.eps", width = 8, height = 5, + size_units = "in", res = 100, ...) +} +\arguments{ +\item{var1}{Matrix of dimensions (nexp/nmod, nltime).} + +\item{var2}{Matrix of dimensions (nexp/nmod, nltime).} + +\item{toptitle}{Main title, optional.} + +\item{ytitle}{Title of Y-axis, optional.} + +\item{monini}{Starting month between 1 and 12. Default = 1.} + +\item{freq}{1 = yearly, 12 = monthly, 4 = seasonal, ... Default = 12.} + +\item{nticks}{Number of ticks and labels on the x-axis, optional.} + +\item{limits}{c(lower limit, upper limit): limits of the Y-axis, optional.} + +\item{listexp}{List of experiment names, up to three, optional.} + +\item{listvars}{List of names of input variables, optional.} + +\item{biglab}{TRUE/FALSE for presentation/paper plot. Default = FALSE.} + +\item{hlines}{c(a, b, ...) Add horizontal black lines at Y-positions a, b, +...\cr +Default: NULL.} + +\item{leg}{TRUE/FALSE if legend should be added or not to the plot. +Default = TRUE.} + +\item{siglev}{TRUE/FALSE if significance level should replace confidence +interval.\cr +Default = FALSE.} + +\item{sizetit}{Multiplicative factor to change title size, optional.} + +\item{show_conf}{TRUE/FALSE to show/not confidence intervals for input +variables.} + +\item{fileout}{Name of output file. Extensions allowed: eps/ps, jpeg, png, +pdf, bmp and tiff. \cr +Default = 'output_plot2varsvsltime.eps'} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{...}{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 fig font font.axis font.lab font.main font.sub lend +lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page pch plt +smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +For more information about the parameters see `par`.} +} +\description{ +Plots two input variables having the same dimensions in a common plot.\cr +One plot for all experiments.\cr +Input variables should have dimensions (nexp/nmod, nltime). +} +\details{ +Examples of input:\cr +------------------\cr\cr +RMSE error for a number of experiments and along lead-time: (nexp, nltime) +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +runmean_months <- 12 +dim_to_smooth <- 4 # Smooth along lead-times +smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +dim_to_mean <- 2 # Mean along members +required_complete_row <- 3 # Discard start dates that contain NA along lead-times +leadtimes_per_startdate <- 60 +rms <- RMS(Mean1Dim(smooth_ano_exp, dim_to_mean), + Mean1Dim(smooth_ano_obs, dim_to_mean), + compROW = required_complete_row, + limits = c(ceiling((runmean_months + 1) / 2), + leadtimes_per_startdate - floor(runmean_months / 2))) +smooth_ano_exp_m_sub <- smooth_ano_exp - InsertDim(Mean1Dim(smooth_ano_exp, 2, + narm = TRUE), 2, dim(smooth_ano_exp)[2]) +spread <- Spread(smooth_ano_exp_m_sub, c(2, 3)) + \donttest{ +Plot2VarsVsLTime(InsertDim(rms[, , , ], 1, 1), spread$sd, + toptitle = 'RMSE and spread', monini = 11, freq = 12, + listexp = c('CMIP5 IC3'), listvar = c('RMSE', 'spread'), + fileout = 'plot2vars.eps') + } + +} +\author{ +History:\cr +1.0 - 2013-03 (I. Andreu-Burillo, \email{isabel.andreu-burillo@ic3.cat}) + - Original code +} +\keyword{dynamic} + diff --git a/man/PlotACC.Rd b/man/PlotACC.Rd new file mode 100644 index 0000000..fc66200 --- /dev/null +++ b/man/PlotACC.Rd @@ -0,0 +1,125 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotACC.R +\name{PlotACC} +\alias{PlotACC} +\title{Plot Plumes/Timeseries Of Anomaly Correlation Coefficients} +\usage{ +PlotACC(ACC, sdates, toptitle = "", sizetit = 1, ytitle = "", + limits = NULL, legends = NULL, freq = 12, biglab = FALSE, + fill = FALSE, linezero = FALSE, points = TRUE, vlines = NULL, + fileout = "output_PlotACC.eps", width = 8, height = 5, + size_units = "in", res = 100, ...) +} +\arguments{ +\item{ACC}{ACC matrix with with dimensions:\cr +c(nexp, nobs, nsdates, nltime, 4)\cr +with the fourth dimension of length 4 containing the lower limit of the +95\% confidence interval, the ACC, the upper limit of the 95\% confidence +interval and the 95\% significance level.} + +\item{sdates}{List of startdates: c('YYYYMMDD','YYYYMMDD').} + +\item{toptitle}{Main title, optional.} + +\item{sizetit}{Multiplicative factor to scale title size, optional.} + +\item{ytitle}{Title of Y-axis for each experiment: c('',''), optional.} + +\item{limits}{c(lower limit, upper limit): limits of the Y-axis, optional.} + +\item{legends}{List of flags (characters) to be written in the legend, +optional.} + +\item{freq}{1 = yearly, 12 = monthly, 4 = seasonal, ... Default: 12.} + +\item{biglab}{TRUE/FALSE for presentation/paper plot, Default = FALSE.} + +\item{fill}{TRUE/FALSE if filled confidence interval. Default = FALSE.} + +\item{linezero}{TRUE/FALSE if a line at y=0 should be added. Default = FALSE.} + +\item{points}{TRUE/FALSE if points instead of lines. Default = TRUE.\cr +Must be TRUE if only 1 leadtime.} + +\item{vlines}{List of x location where to add vertical black lines, optional.} + +\item{fileout}{Name of output file. Extensions allowed: eps/ps, jpeg, png, +pdf, bmp and tiff. \cr +Default = 'output_PlotACC.eps'} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{\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 fig fin font font.axis font.lab font.main font.sub +lend lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page +plt smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog\cr +For more information about the parameters see `par`.} +} +\description{ +Plots plumes/timeseries of ACC from an array with dimensions +(output from \code{ACC()}): \cr +c(nexp, nobs, nsdates, nltime, 4)\cr +where the fourth dimension is of length 4 and contains the lower limit of +the 95\% confidence interval, the ACC, the upper limit of the 95\% +confidence interval and the 95\% significance level given by a one-sided +T-test. +} +\examples{ +# See examples on Load() to understand the first lines in this example + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + leadtimemin = 1, leadtimemax = 4, output = 'lonlat', + latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } +sampleData$mod <- Season(sampleData$mod, 4, 11, 12, 2) +sampleData$obs <- Season(sampleData$obs, 4, 11, 12, 2) +clim <- Clim(sampleData$mod, sampleData$obs) +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +acc <- ACC(Mean1Dim(sampleData$mod, 2), + Mean1Dim(sampleData$obs, 2)) + \donttest{ +PlotACC(acc$ACC, startDates, toptitle = "Anomaly Correlation Coefficient") + + } +} +\author{ +History:\cr +0.1 - 2013-08 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +} +\keyword{dynamic} + diff --git a/man/PlotAno.Rd b/man/PlotAno.Rd new file mode 100644 index 0000000..dd05931 --- /dev/null +++ b/man/PlotAno.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotAno.R +\name{PlotAno} +\alias{PlotAno} +\title{Plot Raw Or Smoothed Anomalies} +\usage{ +PlotAno(exp_ano, obs_ano = NULL, sdates, toptitle = rep("", 15), + ytitle = rep("", 15), limits = NULL, legends = NULL, freq = 12, + biglab = FALSE, fill = TRUE, memb = TRUE, ensmean = TRUE, + linezero = FALSE, points = FALSE, vlines = NULL, sizetit = 1, + fileout = paste0("output", 1:5, "_plotano.eps"), width = 8, height = 5, + size_units = "in", res = 100, ...) +} +\arguments{ +\item{exp_ano}{Array containing the experimental data:\cr +c(nmod/nexp, nmemb/nparam, nsdates, nltime).} + +\item{obs_ano}{Optional matrix containing the observational data:\cr +c(nobs, nmemb, nsdates, nltime)} + +\item{sdates}{List of starting dates: c('YYYYMMDD','YYYYMMDD').} + +\item{toptitle}{Main title for each experiment: c('',''), optional.} + +\item{ytitle}{Title of Y-axis for each experiment: c('',''), optional.} + +\item{limits}{c(lower limit, upper limit): limits of the Y-axis, optional.} + +\item{legends}{List of observational dataset names, optional.} + +\item{freq}{1 = yearly, 12 = monthly, 4 = seasonal, ... Default: 12.} + +\item{biglab}{TRUE/FALSE for presentation/paper plot. Default = FALSE.} + +\item{fill}{TRUE/FALSE if the spread between members should be filled. +Default = TRUE.} + +\item{memb}{TRUE/FALSE if all members/only the ensemble-mean should be +plotted.\cr +Default = TRUE.} + +\item{ensmean}{TRUE/FALSE if the ensemble-mean should be plotted. +Default = TRUE.} + +\item{linezero}{TRUE/FALSE if a line at y=0 should be added. +Default = FALSE.} + +\item{points}{TRUE/FALSE if points instead of lines should be shown. +Default = FALSE.} + +\item{vlines}{List of x location where to add vertical black lines, optional.} + +\item{sizetit}{Multiplicative factor to scale title size, optional.} + +\item{fileout}{Name of the output file for each experiment: c('',''). +Extensions allowed: eps/ps, jpeg, png, pdf, bmp and tiff. If filenames +with different extensions are passed, it will be considered only the first +one and it will be extended to the rest. \cr +Default = c('output1_plotano.eps', 'output2_plotano.eps', + 'output3_plotano.eps', 'output4_plotano.eps', + 'output5_plotano.eps')} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{\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 fig font font.axis font.lab font.main font.sub lend +lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page plt smo +srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +For more information about the parameters see `par`.} +} +\description{ +Plots timeseries of raw or smoothed anomalies of any variable output from +\code{Load()} or \code{Ano()} or or \code{Ano_CrossValid()} or +\code{Smoothing()}. +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +runmean_nb_months <- 12 +dim_to_smooth <- 4 # Smooth along lead-times +smooth_ano_exp <- Smoothing(ano_exp, runmean_nb_months, dim_to_smooth) +smooth_ano_obs <- Smoothing(ano_obs, runmean_nb_months, dim_to_smooth) + \donttest{ +PlotAno(smooth_ano_exp, smooth_ano_obs, startDates, + toptitle = paste('smoothed anomalies'), ytitle = c('K', 'K', 'K'), + legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano.eps') + } + +} +\author{ +History:\cr +0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +} +\keyword{dynamic} + diff --git a/man/PlotBoxWhisker.Rd b/man/PlotBoxWhisker.Rd new file mode 100644 index 0000000..a536686 --- /dev/null +++ b/man/PlotBoxWhisker.Rd @@ -0,0 +1,134 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotBoxWhisker.R +\name{PlotBoxWhisker} +\alias{PlotBoxWhisker} +\title{Box-And-Whisker Plot of Time Series with Ensemble Distribution} +\usage{ +PlotBoxWhisker(exp, obs, toptitle = "", ytitle = "", monini = 1, + yearini = 0, freq = 1, expname = "exp 1", obsname = "obs 1", + drawleg = TRUE, fileout = "output_PlotBoxWhisker.ps", width = 8, + height = 5, size_units = "in", res = 100, ...) +} +\arguments{ +\item{exp}{Forecast array of multi-member time series, e.g., the NAO index +of one experiment. The expected dimensions are +c(members, start dates/forecast horizons). A vector with only the time +dimension can also be provided. Only monthly or lower frequency time +series are supported. See parameter freq.} + +\item{obs}{Observational vector or array of time series, e.g., the NAO index +of the observations that correspond the forecast data in \code{exp}. +The expected dimensions are c(start dates/forecast horizons) or +c(1, start dates/forecast horizons). Only monthly or lower frequency time +series are supported. See parameter freq.} + +\item{toptitle}{Character string to be drawn as figure title.} + +\item{ytitle}{Character string to be drawn as y-axis title.} + +\item{monini}{Number of the month of the first time step, from 1 to 12.} + +\item{yearini}{Year of the first time step.} + +\item{freq}{Frequency of the provided time series: 1 = yearly, 12 = monthly,} + +\item{expname}{Experimental dataset name.} + +\item{obsname}{Name of the observational reference dataset.} + +\item{drawleg}{TRUE/FALSE: whether to draw the legend or not.} + +\item{fileout}{Name of output file. Extensions allowed: eps/ps, jpeg, png, +pdf, bmp and tiff. \cr +Default = 'output_PlotBox.ps'.} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{...}{Arguments to be passed to the method. Only accepts the following +graphical parameters:\cr +ann ask bg cex.lab cex.sub cin col.axis col.lab col.main col.sub cra crt +csi cxy err family fg fig font font.axis font.lab font.main font.sub lend +lheight ljoin lmitre mex mfcol mfrow mfg mkh oma omd omi page pin plt pty +smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +For more information about the parameters see `par`.} +} +\value{ +Generates a file at the path specified via \code{fileout}. +} +\description{ +Produce time series of box-and-whisker plot showing the distribution of the +members of a forecast vs. the observed evolution. The correlation between +forecast and observational data is calculated and displayed. Only works for +n-monthly to n-yearly time series. +} +\examples{ +# See examples on Load() to understand the first lines in this example + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + leadtimemin = 1, leadtimemax = 4, output = 'lonlat', + latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 20, latmax = 80, + lonmin = -80, lonmax = 40) +# No example data is available over NAO region, so in this example we will +# tweak the available data. In a real use case, one can Load() the data over +# NAO region directly. +sampleData$lon[] <- c(40, 280, 340) +attr(sampleData$lon, 'first_lon') <- 280 +attr(sampleData$lon, 'last_lon') <- 40 +attr(sampleData$lon, 'data_across_gw') <- TRUE +sampleData$lat[] <- c(20, 80) +attr(sampleData$lat, 'first_lat') <- 20 +attr(sampleData$lat, 'last_lat') <- 80 + } +# Now ready to compute the EOFs and project on, for example, the first +# variability mode. +ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +nao <- NAO(ano$ano_exp, ano$ano_obs, sampleData$lon, sampleData$lat) +# Finally plot the nao index + \donttest{ +PlotBoxWhisker(nao$NAO_exp, nao$NAO_obs, "NAO index, DJF", "NAO index (PC1) TOS", + monini = 12, yearini = 1985, freq = 1, "Exp. A", "Obs. X") + } + +} +\author{ +History:\cr +0.1 - 2013-09 (F. Lienert, \email{flienert@ic3.cat}) - Original code\cr +0.2 - 2015-03 (L. Batte, \email{lauriane.batte@ic3.cat}) - Removed all\cr + normalization for sake of clarity. +1.0 - 2016-03 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Formatting to R CRAN +} +\seealso{ +EOF, ProjectField, NAO +} +\keyword{datagen} + diff --git a/man/PlotClim.Rd b/man/PlotClim.Rd new file mode 100644 index 0000000..7ee001e --- /dev/null +++ b/man/PlotClim.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotClim.R +\name{PlotClim} +\alias{PlotClim} +\title{Plots Climatologies} +\usage{ +PlotClim(exp_clim, obs_clim = NULL, toptitle = "", ytitle = "", + monini = 1, freq = 12, limits = NULL, listexp = c("exp1", "exp2", + "exp3"), listobs = c("obs1", "obs2", "obs3"), biglab = FALSE, + leg = TRUE, sizetit = 1, fileout = "output_plotclim.eps", width = 8, + height = 5, size_units = "in", res = 100, ...) +} +\arguments{ +\item{exp_clim}{Matrix containing the experimental data with dimensions:\cr +c(nmod/nexp, nmemb/nparam, nltime) or c(nmod/nexp, nltime)} + +\item{obs_clim}{Matrix containing the observational data (optional) with +dimensions:\cr +c(nobs, nmemb, nltime) or c(nobs, nltime)} + +\item{toptitle}{Main title, optional.} + +\item{ytitle}{Title of Y-axis, optional.} + +\item{monini}{Starting month between 1 and 12. Default = 1.} + +\item{freq}{1 = yearly, 12 = monthly, 4 = seasonal, ... Default = 12.} + +\item{limits}{c(lower limit, upper limit): limits of the Y-axis, optional.} + +\item{listexp}{List of experiment names, optional.} + +\item{listobs}{List of observational dataset names, optional.} + +\item{biglab}{TRUE/FALSE for presentation/paper plot. Default = FALSE.} + +\item{leg}{TRUE/FALSE to plot the legend or not.} + +\item{sizetit}{Multiplicative factor to scale title size, optional.} + +\item{fileout}{Name of output file. Extensions allowed: eps/ps, jpeg, png, +pdf, bmp and tiff. \cr +Default = 'output_plotclim.eps'.} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{...}{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 fig font font.axis font.lab font.main font.sub lend +lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page pch plt +smo srt tck usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +For more information about the parameters see `par`.} +} +\description{ +Plots climatologies as a function of the forecast time for any index output +from \code{Clim()} and organized in matrix with dimensions:\cr +c(nmod/nexp, nmemb/nparam, nltime) or c(nmod/nexp, nltime) for the +experiment data\cr +c(nobs, nmemb, nltime) or c(nobs, nltime) for the observational data +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) + \donttest{ +PlotClim(clim$clim_exp, clim$clim_obs, toptitle = paste('climatologies'), + ytitle = 'K', monini = 11, listexp = c('CMIP5 IC3'), + listobs = c('ERSST'), biglab = FALSE, fileout = 'tos_clim.eps') + } + +} +\author{ +History:\cr +0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +} +\keyword{datagen} + diff --git a/man/PlotEquiMap.Rd b/man/PlotEquiMap.Rd new file mode 100644 index 0000000..cb33fc6 --- /dev/null +++ b/man/PlotEquiMap.Rd @@ -0,0 +1,291 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotEquiMap.R +\name{PlotEquiMap} +\alias{PlotEquiMap} +\title{Maps A Two-Dimensional Variable On A Cylindrical Equidistant Projection} +\usage{ +PlotEquiMap(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, contours = NULL, brks2 = NULL, contour_lwd = 0.5, + contour_color = "black", contour_lty = 1, 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, 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, + ...) +} +\arguments{ +\item{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.} + +\item{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).} + +\item{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].} + +\item{varu}{Array of the zonal component of wind/current/other field with +the same dimensions as 'var'.} + +\item{varv}{Array of the meridional component of wind/current/other field +with the same dimensions as 'var'.} + +\item{toptitle}{Top title of the figure, scalable with parameter +'title_scale'.} + +\item{sizetit}{Scale factor for the figure top title provided in parameter +'toptitle'. Deprecated. Use 'title_scale' instead.} + +\item{units}{Title at the top of the colour bar, most commonly the units of +the variable provided in parameter 'var'.} + +\item{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.} + +\item{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'.} + +\item{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.} + +\item{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.} + +\item{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.} + +\item{coast_color}{Colour of the coast line of the drawn projected 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. Disregarded if 'square = FALSE'.} + +\item{brks2}{Vector of magnitude breaks where to draw contour curves for the +array provided in 'contours' or if 'square = FALSE'.} + +\item{contour_lwd}{Line width of the contour curves provided via 'contours' +and 'brks2', or if 'square = FALSE'.} + +\item{contour_color}{Line color of the contour curves provided via 'contours' +and 'brks2', or if 'square = FALSE'.} + +\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.} + +\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 +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'.} + +\item{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.} + +\item{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.} + +\item{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.} + +\item{arr_scale}{Scale factor for drawn arrows from 'varu' and 'varv'. +Takes 1 by default.} + +\item{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.} + +\item{arr_units}{Units of 'varu' and 'varv', to be drawn in the legend. +Takes 'm/s' by default.} + +\item{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.} + +\item{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.} + +\item{axelab}{Whether to draw longitude and latitude axes or not. +TRUE by default.} + +\item{labW}{Whether to label the longitude axis with a 'W' instead of minus +for negative values. Defaults to FALSE.} + +\item{intylat}{Interval between latitude ticks on y-axis, in degrees. +Defaults to 20.} + +\item{intxlon}{Interval between latitude ticks on x-axis, in degrees. +Defaults to 20.} + +\item{axes_tick_scale}{Scale factor for the tick lines along the longitude +and latitude axes.} + +\item{axes_label_scale}{Scale factor for the labels along the longitude +and latitude axes.} + +\item{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.} + +\item{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.} + +\item{boxcol}{Colour of the box lines. A vector with a colour for each of +the boxes is also accepted. Defaults to 'purple2'.} + +\item{boxlwd}{Line width of the box lines. A vector with a line width for +each of the boxes is also accepted. Defaults to 5.} + +\item{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.} + +\item{title_scale}{Scale factor for the figure top title. Defaults to 1.} + +\item{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.} + +\item{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.} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{\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`.} +} +\value{ +\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). +} +} +\description{ +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. This plot function is compatible with figure layouts if colour +bar is disabled. +} +\examples{ +# See examples on Load() to understand the first lines in this example + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + leadtimemin = 1, leadtimemax = 4, output = 'lonlat', + latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } +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) +} +\author{ +History:\cr + 0.1 - 2011-11 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr + 0.2 - 2013-04 (R. Saurral \email{ramiro.saurral@ic3.cat}) - LabW\cr + 1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to R CRAN\cr + 1.1 - 2013-09 (C. Prodhomme, \email{chloe.prodhomme@ic3.cat}) - add winds\cr + 1.2 - 2016-08 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Refactored and added features, + and adapted to new ColorBar. +} +\keyword{dynamic} + diff --git a/man/PlotLayout.Rd b/man/PlotLayout.Rd new file mode 100644 index 0000000..e4cf4ec --- /dev/null +++ b/man/PlotLayout.Rd @@ -0,0 +1,252 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotLayout.R +\name{PlotLayout} +\alias{PlotLayout} +\title{Arrange and Fill Multi-Pannel Layouts With Optional Colour Bar} +\usage{ +PlotLayout(fun, plot_dims, var, ..., special_args = NULL, nrow = NULL, + ncol = NULL, toptitle = NULL, row_titles = NULL, col_titles = NULL, + bar_scale = 1, title_scale = 1, title_margin_scale = 1, + title_left_shift_scale = 1, subtitle_scale = 1, + subtitle_margin_scale = 1, brks = NULL, cols = NULL, drawleg = "S", + titles = NULL, subsampleg = NULL, bar_limits = NULL, + triangle_ends = NULL, col_inf = NULL, col_sup = NULL, + color_fun = clim.colors, draw_bar_ticks = TRUE, draw_separators = FALSE, + triangle_ends_scale = 1, bar_extra_labels = NULL, units = NULL, + units_scale = 1, bar_label_scale = 1, bar_tick_scale = 1, + bar_extra_margin = rep(0, 4), bar_left_shift_scale = 1, + bar_label_digits = 4, extra_margin = rep(0, 4), fileout = NULL, + width = NULL, height = NULL, size_units = "in", res = 100, + close_device = TRUE) +} +\arguments{ +\item{fun}{Plot function (or name of the function) to be called on the +arrays provided in 'var'. If multiple arrays are provided in 'var', a +vector of as many function names (character strings!) can be provided in +'fun', one for each array in 'var'.} + +\item{plot_dims}{Numeric or character string vector with identifiers of the +input plot dimensions of the plot function specified in 'fun'. If +character labels are provided, names(dim(var)) or attr('dimensions', var) +will be checked to locate the dimensions. As many plots as +prod(dim(var)[-plot_dims]) will be generated. If multiple arrays are +provided in 'var', 'plot_dims' can be sent a list with a vector of plot +dimensions for each. If a single vector is provided, it will be used for +all the arrays in 'var'.} + +\item{var}{Multi-dimensional array with at least the dimensions expected by +the specified plot function in 'fun'. The dimensions reqired by the +function must be specified in 'plot_dims'. The dimensions can be +disordered and will be reordered automatically. Dimensions can optionally +be labelled in order to refer to them with names in 'plot_dims'. All the +available plottable sub-arrays will be automatically plotted and arranged +in consecutive cells of an automatically arranged layout. A list of +multiple (super-)arrays can be specified. The process will be repeated for +each of them, by default applying the same plot function to all of them +or, if properly specified in 'fun', a different plot function will be +applied to each of them. NAs can be passed to the list: a NA will yield a +blank cell in the layout, which can be populated after +(see .SwitchToFigure).} + +\item{special_args}{List of sub-lists, each sub-list having specific extra +arguments for each of the plot functions provided in 'fun'. If you want to +fix a different value for each plot in the layout you can do so by +a) splitting your array into a list of sub-arrays (each with the data for +one plot) and providing it as parameter 'var', +b) providing a list of named sub-lists in 'special_args', where the names +of each sub-list match the names of the parameters to be adjusted, and +each value in a sub-list contains the value of the corresponding parameter.} + +\item{nrow}{Numeric value to force the number of rows in the automatically +generated layout. If higher than the required, this will yield blank cells +in the layout (which can then be populated). If lower than the required +the function will stop. By default it is configured to arrange the layout +in a shape as square as possible. Blank cells can be manually populated +after with customized plots (see SwitchTofigure).} + +\item{ncol}{Numeric value to force the number of columns in the +automatically generated layout. If higher than the required, this will +yield blank cells in the layout (which can then be populated). If lower +than the required the function will stop. By default it is configured to +arrange the layout in a shape as square as possible. Blank cells can be +manually populated after with customized plots (see SwitchTofigure).} + +\item{toptitle}{Topt title for the multi-pannel. Blank by default.} + +\item{row_titles}{Character string vector with titles for each of the rows +in the layout. Blank by default.} + +\item{col_titles}{Character string vector with titles for each of the +columns in the layout. Blank by default.} + +\item{bar_scale}{Scale factor for the common colour bar. Takes 1 by default.} + +\item{title_scale}{Scale factor for the multi-pannel title. Takes 1 by +default.} + +\item{title_margin_scale}{Scale factor for the margins surrounding the top +title. Takes 1 by default.} + +\item{title_left_shift_scale}{When plotting row titles, a shift is added +to the horizontal positioning of the top title in order to center it to +the region of the figures (without taking row titles into account). This +shift can be reduced. A value of 0 will remove the shift completely, +centering the title to the total width of the device. This parameter will +be disregarded if no 'row_titles' are provided.} + +\item{subtitle_scale}{Scale factor for the row titles and column titles +(specified in 'row_titles' and 'col_titles'). Takes 1 by default.} + +\item{subtitle_margin_scale}{Scale factor for the margins surrounding the +subtitles. Takes 1 by default.} + +\item{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.} + +\item{drawleg}{Where to draw the common colour bar. Can take values TRUE, +FALSE or:\cr +'up', 'u', 'U', 'top', 't', 'T', 'north', 'n', 'N'\cr +'down', 'd', 'D', 'bottom', 'b', 'B', 'south', 's', 'S' (default)\cr +'right', 'r', 'R', 'east', 'e', 'E'\cr +'left', 'l', 'L', 'west', 'w', 'W'} + +\item{titles}{Character string vector with titles for each of the figures in +the multi-pannel, from top-left to bottom-right. Blank by default.} + +\item{col_inf, col_sup}{Colour identifiers to colour the values in 'var' that +go beyond the extremes of the colour bar and to colour NA values, +respectively. 'colNA' takes 'white' by default. 'col_inf' and 'col_sup' +will take the value of 'colNA' if not specified. See ?ColorBar for a full +explanation on 'col_inf' and 'col_sup'.} + +\item{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.} + +\item{units}{Title at the top of the colour bar, most commonly the units of +the variable provided in parameter 'var'.} + +\item{bar_left_shift_scale}{When plotting row titles, a shift is added to +the horizontal positioning of the colour bar in order to center it to the +region of the figures (without taking row titles into account). This shift +can be reduced. A value of 0 will remove the shift completely, centering +the colour bar to the total width of the device. This parameter will be +disregarded if no 'row_titles' are provided.} + +\item{extra_margin}{Extra margins to be added around the layout, in the +format c(y1, x1, y2, x2). The units are margin lines. Takes rep(0, 4) +by default.} + +\item{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.} + +\item{width}{Width in inches of the multi-pannel. 7 by default, or 11 if +'fielout' has been specified.} + +\item{height}{Height in inches of the multi-pannel. 7 by default, or 11 if +'fileout' has been specified.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{close_device}{Whether to close the graphics device after plotting +the layout and a 'fileout' has been specified. This is useful to avoid +closing the device when saving the layout into a file and willing to add +extra elements or figures. Takes TRUE by default. Disregarded if no +'fileout' has been specified.} + +\item{\dots}{Parameters to be sent to the plotting function 'fun'. If +multiple arrays are provided in 'var' and multiple functions are provided +in 'fun', the parameters provided through \dots will be sent to all the +plot functions, as common parameters. To specify concrete arguments for +each of the plot functions see parameter 'special_args'.} +} +\value{ +\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). +} +\item{layout_matrix}{ + Underlying matrix of the layout. Useful to later set any of the layout + cells as current figure to add plot elements. See .SwitchToFigure. +} +} +\description{ +This function takes an array or list of arrays and loops over each of them +to plot all the sub-arrays they contain on an automatically generated +multi-pannel layout. A different plot function (not necessarily from +s2dverification) can be applied over each of the provided arrays. The input +dimensions of each of the functions have to be specified, either with the +names or the indices of the corresponding input dimensions. It is possible +to draw a common colour bar at any of the sides of the multi-pannel for all +the s2dverification plots that use a colour bar. Common plotting arguments +for all the arrays in 'var' can be specified via the '...' parameter, and +specific plotting arguments for each array can be fully adjusted via +'special_args'. It is possible to draw titles for each of the figures, +layout rows, layout columns and for the whole figure. A number of parameters +is provided in order to adjust the position, size and colour of the +components. Blank cells can be forced to appear and later be filled in +manually with customized plots.\cr +This function pops up a blank new device and fills it in, so it cannot be +nested in complex layouts. +} +\examples{ +# See examples on Load() to understand the first lines in this example + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + leadtimemin = 1, leadtimemax = 4, output = 'lonlat', + latmin = 27, latmax = 48, lonmin = -12, lonmax = 40) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } +PlotLayout(PlotEquiMap, c('lat', 'lon'), sampleData$mod[1, , 1, 1, , ], + sampleData$lon, sampleData$lat, + toptitle = 'Predicted tos for Nov 1960 from 1st Nov', + titles = paste('Member', 1:15)) + +} +\author{ +History:\cr + 0.1 - 2016-08 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Original code +} +\keyword{dynamic} + diff --git a/man/PlotMatrix.Rd b/man/PlotMatrix.Rd new file mode 100644 index 0000000..70c1211 --- /dev/null +++ b/man/PlotMatrix.Rd @@ -0,0 +1,96 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotMatrix.R +\name{PlotMatrix} +\alias{PlotMatrix} +\title{Function to convert any numerical table to a grid of coloured squares.} +\usage{ +PlotMatrix(var, brks = NULL, cols = NULL, toptitle = NULL, + title.color = "royalblue4", xtitle = NULL, ytitle = NULL, + xlabels = NULL, xvert = FALSE, ylabels = NULL, line = 3, + figure.width = 1, legend = TRUE, legend.width = 0.15, + xlab_dist = NULL, ylab_dist = NULL, fileout = NULL, size_units = "px", + res = 100, ...) +} +\arguments{ +\item{var}{A numerical matrix containing the values to be displayed in a +colored image.} + +\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{cols}{A vector of valid color identifiers for color bar. The length +must be one less than the parameter 'brks'. Use ColorBar() to generate +default values.} + +\item{toptitle}{A string of the title of the grid. Set NULL as default.} + +\item{title.color}{A string of valid color identifier to decide the title +color. Set "royalblue4" as default.} + +\item{xtitle}{A string of title of the x-axis. Set NULL as default.} + +\item{ytitle}{A string of title of the y-axis. Set NULL as default.} + +\item{xlabels}{A vector of labels of the x-axis. The length must be +length of the column of parameter 'var'. Set the sequence from 1 to the +length of the column of parameter 'var' as default.} + +\item{xvert}{A logical value to decide whether to place x-axis labels +vertically. Set FALSE as default, which keeps the labels horizontally.} + +\item{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.} + +\item{line}{An integer specifying the distance between the title of the +x-axis and the x-axis. Set 3 as default. Adjust if the x-axis labels +are long.} + +\item{figure.width}{A positive number as a ratio adjusting the width of the +grids. Set 1 as default.} + +\item{legend}{A logical value to decide to draw the grid color legend or not. +Set TRUE as default.} + +\item{legend.width}{A number between 0 and 0.5 to adjust the legend width. +Set 0.15 as default.} + +\item{xlab_dist}{A number specifying the distance between the x labels and +the x axis. If not specified, it equals to -1 - (nrow(var) / 10 - 1).} + +\item{ylab_dist}{A number specifying the distance between the y labels and +the y axis. If not specified, it equals to 0.5 - ncol(var) / 10.} + +\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.} +} +\value{ +A figure in popup window by default, or saved to the specified path. +} +\description{ +This function converts a numerical data matrix into a coloured +grid. It is useful for a slide or article to present tabular results as +colors instead of numbers. +} +\examples{ +#Example with random data +PlotMatrix(var = matrix(rnorm(n = 120, mean = 0.3), 10, 12), + 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), + toptitle = "Mean Absolute Error", + xtitle = "Forecast time (month)", ytitle = "Start date", + xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + "Aug", "Sep", "Oct", "Nov", "Dec")) +} + diff --git a/man/PlotSection.Rd b/man/PlotSection.Rd new file mode 100644 index 0000000..f744731 --- /dev/null +++ b/man/PlotSection.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotSection.R +\name{PlotSection} +\alias{PlotSection} +\title{Plots A Vertical Section} +\usage{ +PlotSection(var, horiz, depth, toptitle = "", sizetit = 1, units = "", + brks = NULL, cols = NULL, axelab = TRUE, intydep = 200, + intxhoriz = 20, drawleg = TRUE, fileout = NULL, width = 8, + height = 5, size_units = "in", res = 100, ...) +} +\arguments{ +\item{var}{Matrix to plot with (longitude/latitude, depth) dimensions.} + +\item{horiz}{Array of longitudes or latitudes.} + +\item{depth}{Array of depths.} + +\item{toptitle}{Title, optional.} + +\item{sizetit}{Multiplicative factor to increase title size, optional.} + +\item{units}{Units, optional.} + +\item{brks}{Colour levels, optional.} + +\item{cols}{List of colours, optional.} + +\item{axelab}{TRUE/FALSE, label the axis. Default = TRUE.} + +\item{intydep}{Interval between depth ticks on y-axis. Default: 200m.} + +\item{intxhoriz}{Interval between longitude/latitude ticks on x-axis.\cr +Default: 20deg.} + +\item{drawleg}{Draw colorbar. Default: TRUE.} + +\item{fileout}{Name of output file. Extensions allowed: eps/ps, jpeg, png, +pdf, bmp and tiff. \cr +Default = NULL} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{...}{Arguments to be passed to the method. Only accepts the following +graphical parameters:\cr +adj ann ask bg bty cex.lab cex.sub cin col.axis col.lab col.main col.sub +cra crt csi cxy err family fg fig fin font font.axis font.lab font.main +font.sub lend lheight ljoin lmitre lty lwd mex mfcol mfrow mfg mkh oma 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`.} +} +\description{ +Plot a (longitude,depth) or (latitude,depth) section. +} +\examples{ +sampleData <- s2dverification::sampleDepthData +PlotSection(sampleData$mod[1, 1, 1, 1, , ], sampleData$lat, sampleData$depth, + toptitle = 'temperature 1995-11 member 0') +} +\author{ +History:\cr +0.1 - 2012-09 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.0 - 2013-09 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +} +\keyword{dynamic} + diff --git a/man/PlotStereoMap.Rd b/man/PlotStereoMap.Rd new file mode 100644 index 0000000..3bf2f69 --- /dev/null +++ b/man/PlotStereoMap.Rd @@ -0,0 +1,195 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotStereoMap.R +\name{PlotStereoMap} +\alias{PlotStereoMap} +\title{Maps A Two-Dimensional Variable On A Polar Stereographic Projection} +\usage{ +PlotStereoMap(var, lon, lat, latlims = c(60, 90), 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(), + filled.continents = FALSE, coast_color = NULL, coast_width = 1, + dots = NULL, dot_symbol = 4, dot_size = 0.8, intlat = 10, + 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 = 6, + height = 5, size_units = "in", res = 100, ...) +} +\arguments{ +\item{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.} + +\item{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).} + +\item{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].} + +\item{latlims}{Latitudinal limits of the figure.\cr +Example : c(60, 90) for the North Pole\cr + c(-90,-60) for the South Pole} + +\item{toptitle}{Top title of the figure, scalable with parameter +'title_scale'.} + +\item{sizetit}{Scale factor for the figure top title provided in parameter +'toptitle'. Deprecated. Use 'title_scale' instead.} + +\item{units}{Title at the top of the colour bar, most commonly the units of +the variable provided in parameter 'var'.} + +\item{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.} + +\item{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'.} + +\item{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.} + +\item{filled.continents}{Colour to fill in drawn projected continents. Takes +the value gray(0.5) by default. If set to FALSE, continents are not +filled in.} + +\item{coast_color}{Colour of the coast line of the drawn projected +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{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'.} + +\item{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.} + +\item{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.} + +\item{intlat}{Interval between latitude lines (circles), in degrees. +Defaults to 10.} + +\item{drawleg}{Whether to plot a color bar (legend, key) or not. +Defaults to TRUE.} + +\item{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.} + +\item{boxcol}{Colour of the box lines. A vector with a colour for each of +the boxes is also accepted. Defaults to 'purple2'.} + +\item{boxlwd}{Line width of the box lines. A vector with a line width for +each of the boxes is also accepted. Defaults to 5.} + +\item{margin_scale}{Scale factor for the margins to be added to the plot, +with the format c(y1, x1, y2, x2). Defaults to rep(1, 4). If drawleg = TRUE, +margin_scale[1] is subtracted 1 unit.} + +\item{title_scale}{Scale factor for the figure top title. Defaults to 1.} + +\item{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.} + +\item{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.} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{\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`.} +} +\value{ +\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). +} +} +\description{ +Map longitude-latitude array (on a regular rectangular or gaussian grid) on +a polar stereographic world projection with coloured grid cells. Only the +region within a specified latitude interval is displayed. A colour bar +(legend) can be plotted and adjusted. It is possible to draw superimposed +dots, symbols and boxes. A number of options is provided to adjust the +position, size and colour of the components. This plot function is +compatible with figure layouts if colour bar is disabled. +} +\examples{ +data <- matrix(rnorm(100 * 50), 100, 50) +x <- seq(from = 0, to = 360, length.out = 100) +y <- seq(from = -90, to = 90, length.out = 50) +PlotStereoMap(data, x, y, latlims = c(60, 90), brks = 50, + toptitle = "This is the title") +} +\author{ +History:\cr +1.0 - 2014-07 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +1.1 - 2015-12 (C. Ardilouze, \email{constantin.ardilouze@meteo.fr}) - Box(es) drawing\cr +1.2 - 2016-08 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Refacotred the function and + merged in Jean-Philippe circle + border and Constantin boxes. +} +\keyword{dynamic} + diff --git a/man/PlotVsLTime.Rd b/man/PlotVsLTime.Rd new file mode 100644 index 0000000..2c71e9f --- /dev/null +++ b/man/PlotVsLTime.Rd @@ -0,0 +1,136 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PlotVsLTime.R +\name{PlotVsLTime} +\alias{PlotVsLTime} +\title{Plots A Score Along The Forecast Time With Its Confidence Interval} +\usage{ +PlotVsLTime(var, toptitle = "", ytitle = "", monini = 1, freq = 12, + nticks = NULL, limits = NULL, listexp = c("exp1", "exp2", "exp3"), + listobs = c("obs1", "obs2", "obs3"), biglab = FALSE, hlines = NULL, + leg = TRUE, siglev = FALSE, sizetit = 1, show_conf = TRUE, + fileout = "output_plotvsltime.eps", width = 8, height = 5, + size_units = "in", res = 100, ...) +} +\arguments{ +\item{var}{Matrix containing any Prediction Score with dimensions:\cr +(nexp/nmod, 3/4 ,nltime)\cr +or (nexp/nmod, nobs, 3/4 ,nltime).} + +\item{toptitle}{Main title, optional.} + +\item{ytitle}{Title of Y-axis, optional.} + +\item{monini}{Starting month between 1 and 12. Default = 1.} + +\item{freq}{1 = yearly, 12 = monthly, 4 = seasonal, ... Default = 12.} + +\item{nticks}{Number of ticks and labels on the x-axis, optional.} + +\item{limits}{c(lower limit, upper limit): limits of the Y-axis, optional.} + +\item{listexp}{List of experiment names, optional.} + +\item{listobs}{List of observation names, optional.} + +\item{biglab}{TRUE/FALSE for presentation/paper plot. Default = FALSE.} + +\item{hlines}{c(a,b, ..) Add horizontal black lines at Y-positions a,b, ...\cr +Default = NULL.} + +\item{leg}{TRUE/FALSE if legend should be added or not to the plot. +Default = TRUE.} + +\item{siglev}{TRUE/FALSE if significance level should replace confidence +interval.\cr +Default = FALSE.} + +\item{sizetit}{Multiplicative factor to change title size, optional.} + +\item{show_conf}{TRUE/FALSE to show/not confidence intervals for input +variables.} + +\item{fileout}{Name of output file. Extensions allowed: eps/ps, jpeg, png, +pdf, bmp and tiff.\cr +Default = 'output_plotvsltime.eps'} + +\item{width}{File width, in the units specified in the parameter size_units +(inches by default). Takes 8 by default.} + +\item{height}{File height, in the units specified in the parameter +size_units (inches by default). Takes 5 by default.} + +\item{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.} + +\item{res}{Resolution of the device (file or window) to plot in. See +?Devices and the creator function of the corresponding device.} + +\item{...}{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 fig font font.axis font.lab font.main font.sub +lheight ljoin lmitre mar mex mfcol mfrow mfg mkh oma omd omi page pch plt +smo srt tck tcl usr xaxp xaxs xaxt xlog xpd yaxp yaxs yaxt ylbias ylog \cr +For more information about the parameters see `par`.} +} +\description{ +Plots The Correlation (\code{Corr()}) or the Root Mean Square Error +(\code{RMS()}) between the forecasted values and their observational +counterpart or the slopes of their trends (\code{Trend()}) or the +InterQuartile Range, Maximum-Mininum, Standard Deviation or Median Absolute +Deviation of the Ensemble Members (\code{Spread()}), or the ratio between +the Ensemble Spread and the RMSE of the Ensemble Mean (\code{RatioSDRMS()}) +along the forecast time for all the input experiments on the same figure +with their confidence intervals. +} +\details{ +Examples of input:\cr +Model and observed output from \code{Load()} then \code{Clim()} then +\code{Ano()} then \code{Smoothing()}:\cr +(nmod, nmemb, nsdate, nltime) and (nobs, nmemb, nsdate, nltime)\cr +then averaged over the members\cr +\code{Mean1Dim(var_exp/var_obs, posdim = 2)}:\cr +(nmod, nsdate, nltime) and (nobs, nsdate, nltime)\cr +then passed through\cr + \code{Corr(exp, obs, posloop = 1, poscor = 2)} or\cr + \code{RMS(exp, obs, posloop = 1, posRMS = 2)}:\cr + (nmod, nobs, 3, nltime)\cr +would plot the correlations or RMS between each exp & each obs as a function +of the forecast time. +} +\examples{ +# Load sample data as in Load() example: +example(Load) +clim <- Clim(sampleData$mod, sampleData$obs) +ano_exp <- Ano(sampleData$mod, clim$clim_exp) +ano_obs <- Ano(sampleData$obs, clim$clim_obs) +runmean_months <- 12 +dim_to_smooth <- 4 # Smooth along lead-times +smooth_ano_exp <- Smoothing(ano_exp, runmean_months, dim_to_smooth) +smooth_ano_obs <- Smoothing(ano_obs, runmean_months, dim_to_smooth) +dim_to_mean <- 2 # Mean along members +required_complete_row <- 3 # Discard startdates for which there are NA leadtimes +leadtimes_per_startdate <- 60 +corr <- Corr(Mean1Dim(smooth_ano_exp, dim_to_mean), + Mean1Dim(smooth_ano_obs, dim_to_mean), + compROW = required_complete_row, + limits = c(ceiling((runmean_months + 1) / 2), + leadtimes_per_startdate - floor(runmean_months / 2))) + \donttest{ +PlotVsLTime(corr, toptitle = "correlations", ytitle = "correlation", + monini = 11, limits = c(-1, 2), listexp = c('CMIP5 IC3'), + listobs = c('ERSST'), biglab = FALSE, hlines = c(-1, 0, 1), + fileout = 'tos_cor.eps') + } + +} +\author{ +History:\cr +0.1 - 2011-03 (V. Guemas, \email{virginie.guemas@ic3.cat}) - Original code\cr +0.2 - 2013-03 (I. Andreu-Burillo, \email{isabel.andreu-burillo@ic3.cat}) - Introduced parameter sizetit\cr +0.3 - 2013-10 (I. Andreu-Burillo, \email{isabel.andreu-burillo@ic3.cat}) - Introduced parameter show_conf\cr +1.0 - 2013-11 (N. Manubens, \email{nicolau.manubens@ic3.cat}) - Formatting to CRAN +} +\keyword{dynamic} + diff --git a/man/ToyModel.Rd b/man/ToyModel.Rd new file mode 100644 index 0000000..ca47b44 --- /dev/null +++ b/man/ToyModel.Rd @@ -0,0 +1,128 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ToyModel.R +\name{ToyModel} +\alias{ToyModel} +\title{Synthetic forecast generator imitating seasonal to decadal forecasts. The +components of a forecast: (1) predictabiltiy (2) forecast error (3) +non-stationarity and (4) ensemble generation. The forecast can be computed +for real observations or observations generated artifically.} +\usage{ +ToyModel(alpha = 0.1, beta = 0.4, gamma = 1, sig = 1, trend = 0, + nstartd = 30, nleadt = 4, nmemb = 10, obsini = NULL, fxerr = NULL) +} +\arguments{ +\item{alpha}{Predicabiltiy of the forecast on the observed residuals +Must be a scalar 0 < alpha < 1.} + +\item{beta}{Standard deviation of forecast error +Must be a scalar 0 < beta < 1.} + +\item{gamma}{Factor on the linear trend to sample model uncertainty. Can be +a scalar or a vector of scalars -inf < gammay < inf. +Defining a scalar results in multiple forecast, corresponding to different +models with different trends.} + +\item{sig}{Standard deviation of the residual variability of the forecast. +If observations are provided 'sig' is computed from the observations.} + +\item{trend}{Linear trend of the forecast. The same trend is used for each +lead-time. If observations are provided the 'trend' is computed from the +observations, with potentially different trends for each lead-time. The +trend has no unit and needs to be defined according to the time vector +[1,2,3,... nstartd].} + +\item{nstartd}{Number of start-dates of the forecast. +If observations are provided the 'nstartd' is computed from the observations.} + +\item{nleadt}{Number of lead-times of the forecats. +If observations are provided the 'nleadt' is computed from the observations.} + +\item{nmemb}{Number of members of the forecasts.} + +\item{obsini}{Observations that can be used in the synthetic forecast coming +from Load (anomalies are expected). If no observations are provided +artifical observations are generated based on Gaussian variaiblity with +standard deviation from 'sig' and linear trend from 'trend'.} + +\item{fxerr}{Provides a fixed error of the forecast instead of generating +one from the level of beta. This allows to perform pair of forecasts with +the same conditional error as required for instance in an attribution context.} +} +\value{ +List of forecast with $mod including the forecast and $obs the + observations. The dimensions correspond to + c(length(gamma), nmemb, nstartd, nleadt) +} +\description{ +The toymodel is based on the model presented in Weigel et al. (2008) QJRS +with an extension to consider non-stationary distributions prescribing a +linear trend. The toymodel allows to generate an aritifical forecast +based on obsevations provided by the input (from Load) or artificially +generated observations based on the input parameters (sig, trend). +The forecast can be specfied for any number of start-dates, lead-time and +ensemble members. It imitates components of a forecast: (1) predictabiltiy +(2) forecast error (3) non-stationarity and (4) ensemble generation. +The forecast can be computed for real observations or observations generated +artifically. +} +\examples{ +# Example 1: Generate forecast with artifical observations +# Seasonal prediction example +a <- 0.1 +b <- 0.3 +g <- 1 +sig <- 1 +t <- 0.02 +ntd <- 30 +nlt <- 4 +nm <- 10 +toyforecast <- ToyModel(alpha = a, beta = b, gamma = g, sig = sig, trend = t, + nstartd = ntd, nleadt = nlt, nmemb = nm) + +# Example 2: Generate forecast from loaded observations +# Decadal prediction example + \dontrun{ +data_path <- system.file('sample_data', package = 's2dverification') +expA <- list(name = 'experiment', path = file.path(data_path, + 'model/$EXP_NAME$/$STORE_FREQ$_mean/$VAR_NAME$_3hourly', + '$VAR_NAME$_$START_DATE$.nc')) +obsX <- list(name = 'observation', path = file.path(data_path, + '$OBS_NAME$/$STORE_FREQ$_mean/$VAR_NAME$', + '$VAR_NAME$_$YEAR$$MONTH$.nc')) + +# Now we are ready to use Load(). +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- Load('tos', list(expA), list(obsX), startDates, + output = 'areave', latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dverification:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + output = 'areave', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) + } + +a <- 0.1 +b <- 0.3 +g <- 1 +nm <- 10 + +toyforecast <- ToyModel(alpha = a, beta = b, gamma = g, nmemb = nm, + obsini = sampleData$obs, nstartd = 5, nleadt = 60) + \donttest{ +PlotAno(toyforecast$mod, toyforecast$obs, startDates, + toptitle = c("Synthetic decadal temperature prediction"), + fileout = "ex_toymodel.eps") + } + +} +\author{ +History:\cr +1.0 - 2014-08 (O.Bellprat) - Original code +1.1 - 2016-02 (O.Bellprat) - Include security check for parameters +} +\keyword{datagen} + diff --git a/man/clim.palette.Rd b/man/clim.palette.Rd new file mode 100644 index 0000000..95f8407 --- /dev/null +++ b/man/clim.palette.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/clim.palette.R +\name{clim.palette} +\alias{clim.colors} +\alias{clim.palette} +\title{Generate Climate Color Palettes} +\usage{ +clim.palette(palette = "bluered") + +clim.colors(n, palette = "bluered") +} +\arguments{ +\item{palette}{Which type of palette to generate: from blue through white +to red ('bluered'), from red through white to blue ('redblue'), from +yellow through orange to red ('yellowred'), or from red through orange +to red ('redyellow').} + +\item{n}{Number of colors to generate.} +} +\description{ +Generates a colorblind friendly color palette with color ranges useful in +climate temperature variable plotting. +} +\examples{ +lims <- seq(-1, 1, length.out = 21) + +ColorBar(lims, color_fun = clim.palette('redyellow')) + +cols <- clim.colors(20) +ColorBar(lims, cols) + +} +\author{ +History:\cr +0.0 - 2016-01 (N. Manubens, \email{nicolau.manubens@bsc.es}) - Original code. +} +\keyword{datagen} + -- GitLab