From ad36caed19ddc6a5dcd3d867e16173321b148437 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 13 Jan 2021 19:08:20 +0100 Subject: [PATCH 01/28] Transfer EOF.R from s2dverification and create unit test --- NAMESPACE | 1 + R/EOF.R | 258 ++++++++++++++++++++++++++++++++++++++ man/EOF.Rd | 92 ++++++++++++++ man/MeanDims.Rd | 2 +- tests/testthat/test-EOF.R | 213 +++++++++++++++++++++++++++++++ 5 files changed, 565 insertions(+), 1 deletion(-) create mode 100644 R/EOF.R create mode 100644 man/EOF.Rd create mode 100644 tests/testthat/test-EOF.R diff --git a/NAMESPACE b/NAMESPACE index 6da8d0c..1eb3cbb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ export(ConfigShowDefinitions) export(ConfigShowSimilarEntries) export(ConfigShowTable) export(Corr) +export(EOF) export(Eno) export(GMST) export(GSAT) diff --git a/R/EOF.R b/R/EOF.R new file mode 100644 index 0000000..7dcf911 --- /dev/null +++ b/R/EOF.R @@ -0,0 +1,258 @@ +#'Area-weighted empirical orthogonal function analysis using SVD +#' +#'Perform an area-weighted EOF analysis using SVD based on a covariance matrix +#'by default, based on the correlation matrix if \code{corr} argument is set to +#'\code{TRUE}. +#' +#'@param ano A numerical array of anomalies with named dimensions to calculate +#' EOF. The dimensions must have at least 'time_dim' and 'space_dim'. +#'@param time_dim A character string indicating the name of the time dimension +#' of 'ano'. +#'@param space_dim A vector of two character strings. The first is the dimension +#' name of latitude of 'ano' and the second is the dimension name of longitude +#' of 'ano'. The default value is c('lat', 'lon'). +#'@param lon A vector of longitudes of 'ano'. +#'@param lat A vector of latitudes of 'ano'. +#'@param neofs An integer of the modes to be kept. The default value is 15. +#' If time length or the product of latitude length and longitude length is +#' less than neofs, neofs is equal to the minimum of the three values. +#'@param corr A logical value indicating whether to base on a correlation (TRUE) +#' or on a covariance matrix (FALSE). The default value is FALSE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list containing: +#'\item{EOFs}{ +#' An array of EOF patterns normalized to 1 (unitless) with dimensions +#' (number of modes, rest of the dimensions of ano except 'time_dim'). +#' Multiplying \code{EOFs} by \code{PCs} gives the original reconstructed +#' field. +#'} +#'\item{PCs}{ +#' An array of principal components with the units of the original field to +#' the power of 2, with dimensions (number of time steps, number of modes). +#' \code{PCs} contains already the percentage of explained variance so, +#' to reconstruct the original field it's only needed to multiply \code{EOFs} +#' by \code{PCs}. +#'} +#'\item{var}{ +#' A vector indicating the percentage (%) of variance fraction of total +#' variance explained by each mode (number of modes). +#'} +#'\item{mask}{ +#' The mask with dimensions (number of latitudes, number of longitudes). +#'} +#'\item{wght}{ +#' The weights with dimensions (number of latitudes, number of longitudes). +#'} +#' +#'@seealso ProjectField, NAO, PlotBoxWhisker +#'@examples +#'# This example computes the EOFs along forecast horizons and plots the one that +#'# explains the greatest amount of variability. The example data is very low +#'# resolution so it does not make a lot of sense. +#'\dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#'} +#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'ano <- MeanDims(ano$ano_exp, 2)[1, , 1, , ] +#'names(dim(ano)) <- c('time', 'lat', 'lon') +#'eof <- EOF(ano, sampleData$lat, sampleData$lon) +#'\dontrun{ +#'PlotEquiMap(eof$EOFs[1, , ], sampleData$lon, sampleData$lat) +#'} +#' +#'@import multiApply +#'@importFrom stats sd +#'@export +EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), + neofs = 15, corr = FALSE, ncores = NULL) { + + # Check inputs + ## ano + if (is.null(ano)) { + stop("Parameter 'ano' cannot be NULL.") + } + if (!is.numeric(ano)) { + stop("Parameter 'ano' must be a numeric array.") + } + if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + stop("Parameter 'ano' 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(ano))) { + stop("Parameter 'time_dim' is not found in 'ano' dimension.") + } + ## space_dim + if (!is.character(space_dim) | length(space_dim) != 2) { + stop("Parameter 'space_dim' must be a character vector of 2.") + } + if (any(!space_dim %in% names(dim(ano)))) { + stop("Parameter 'space_dim' is not found in 'ano' dimension.") + } + ## lat + if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { + stop(paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.")) + } + if (any(lat > 90 | lat < -90)) { + stop("Parameter 'lat' must contain values within the range [-90, 90].") + } + ## lon + if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { + stop(paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.")) + } + if (any(lon > 360 | lon < -360)) { + warning("Some 'lon' is out of the range [-360, 360].") + } + ## neofs + if (!is.numeric(neofs) | neofs %% 1 != 0 | neofs < 0 | length(neofs) > 1) { + stop("Parameter 'neofs' must be a positive integer.") + } + ## corr + if (!is.logical(corr) | length(corr) > 1) { + stop("Parameter 'corr' 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.") + } + } + + + # Replace mask of NAs with 0s for EOF analysis. + ano[!is.finite(ano)] <- 0 + + # Area weighting. Weights for EOF; needed to compute the + # fraction of variance explained by each EOFs + space_ind <- sapply(space_dim, function(a) which(names(dim(ano)) == a)) + wght <- array(cos(lat * pi/180), dim = dim(ano)[space_ind]) + + # We want the covariance matrix to be weigthed by the grid + # cell area so the anomaly field is weighted by its square + # root since the covariance matrix equals transpose(ano) + # times ano. + wght <- sqrt(wght) + + res <- Apply(ano, + target_dims = list(c(time_dim, space_dim), + c(time_dim, space_dim)), + fun = .EOF, + corr = corr, neofs = neofs, + wght = wght, + ncores = ncores) + + return(c(res, wght = list(wght))) + +} + +.EOF <- function(ano, neofs = 15, corr = FALSE, wght = wght) { + # ano: [time, lat, lon] + + # Dimensions + nt <- dim(ano)[1] + ny <- dim(ano)[2] + nx <- dim(ano)[3] + + ano <- ano * InsertDim(wght, 1, nt) + + # Build the mask + mask <- ano[1, , ] + mask[!is.finite(mask)] <- NA + mask[is.finite(mask)] <- 1 + dim(mask) <- dim(ano)[c(2, 3)] + + # The use of the correlation matrix is done under the option corr. + if (corr == TRUE) { + stdv <- apply(ano, c(2, 3), sd, na.rm = T) + ano <- ano/InsertDim(stdv, 1, nt) + } + + # Time/space matrix for SVD + dim(ano) <- c(nt, ny * nx) + dim.dat <- dim(ano) + + # 'transpose' means the array needs to be transposed before + # calling La.svd for computational efficiency because the + # spatial dimension is larger than the time dimension. This + # goes with transposing the outputs of LA.svd also. + if (dim.dat[2] > dim.dat[1]) { + transpose <- TRUE + } else { + transpose <- FALSE + } + if (transpose) { + pca <- La.svd(t(ano)) + } else { + pca <- La.svd(ano) + } + + # neofs is bounded + neofs <- min(dim.dat, neofs) + + # La.svd conventions: decomposition X = U D t(V) La.svd$u + # returns U La.svd$d returns diagonal values of D La.svd$v + # returns t(V) !! The usual convention is PC=U and EOF=V. + # If La.svd is called for ano (transpose=FALSE case): EOFs: + # $v PCs: $u If La.svd is called for t(ano) (transposed=TRUE + # case): EOFs: t($u) PCs: t($v) + + if (transpose) { + pca.EOFs <- t(pca$u) + pca.PCs <- t(pca$v) + } else { + pca.EOFs <- pca$v + pca.PCs <- pca$u + } + + # The numbers of transposition is limited to neofs + PC <- pca.PCs[, 1:neofs] + EOF <- pca.EOFs[1:neofs, ] + dim(EOF) <- c(neofs, ny, nx) + + # To sort out crash when neofs=1. + if (neofs == 1) { + PC <- InsertDim(PC, 2, 1) + } + + # Computation of the % of variance associated with each mode + W <- pca$d[1:neofs] + tot.var <- sum(pca$d^2) + var.eof <- 100 * pca$d[1:neofs]^2/tot.var + + for (e in 1:neofs) { + + # Factor to normalize the EOF. + eof.patt.nn <- EOF[e, , ] * mask + eof.patt.ms <- sum(eof.patt.nn^2, na.rm = TRUE) + + # Normalize the EOF + eof.patt <- eof.patt.nn/eof.patt.ms + + # PC is multiplied by the normalization factor and the + # weights, then the reconstruction is only EOF * PC (we have + # multiplied ano by weight) + eof.pc <- PC[, e] * eof.patt.ms * W[e] + + eof.patt <- eof.patt/wght + + EOF[e, , ] <- eof.patt + PC[, e] <- eof.pc + } + + return(list(EOFs = EOF, PCs = PC, var = var.eof, mask = mask)) +} diff --git a/man/EOF.Rd b/man/EOF.Rd new file mode 100644 index 0000000..782f6cf --- /dev/null +++ b/man/EOF.Rd @@ -0,0 +1,92 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/EOF.R +\name{EOF} +\alias{EOF} +\title{Area-weighted empirical orthogonal function analysis using SVD} +\usage{ +EOF(ano, lat, lon, time_dim = "time", space_dim = c("lat", "lon"), + neofs = 15, corr = FALSE, ncores = NULL) +} +\arguments{ +\item{ano}{A numerical array of anomalies with named dimensions to calculate +EOF. The dimensions must have at least 'time_dim' and 'space_dim'.} + +\item{lat}{A vector of latitudes of 'ano'.} + +\item{lon}{A vector of longitudes of 'ano'.} + +\item{time_dim}{A character string indicating the name of the time dimension +of 'ano'.} + +\item{space_dim}{A vector of two character strings. The first is the dimension +name of latitude of 'ano' and the second is the dimension name of longitude +of 'ano'. The default value is c('lat', 'lon').} + +\item{neofs}{An integer of the modes to be kept. The default value is 15. +If time length or the product of latitude length and longitude length is +less than neofs, neofs is equal to the minimum of the three values.} + +\item{corr}{A logical value indicating whether to base on a correlation (TRUE) +or on a covariance matrix (FALSE). The default value is FALSE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list containing: +\item{EOFs}{ + An array of EOF patterns normalized to 1 (unitless) with dimensions + (number of modes, rest of the dimensions of ano except 'time_dim'). + Multiplying \code{EOFs} by \code{PCs} gives the original reconstructed + field. +} +\item{PCs}{ + An array of principal components with the units of the original field to + the power of 2, with dimensions (number of time steps, number of modes). + \code{PCs} contains already the percentage of explained variance so, + to reconstruct the original field it's only needed to multiply \code{EOFs} + by \code{PCs}. +} +\item{var}{ + A vector indicating the percentage (%) of variance fraction of total + variance explained by each mode (number of modes). +} +\item{mask}{ + The mask with dimensions (number of latitudes, number of longitudes). +} +\item{wght}{ + The weights with dimensions (number of latitudes, number of longitudes). +} +} +\description{ +Perform an area-weighted EOF analysis using SVD based on a covariance matrix +by default, based on the correlation matrix if \code{corr} argument is set to +\code{TRUE}. +} +\examples{ +# This example computes the EOFs along forecast horizons and plots the one that +# explains the greatest amount of variability. The example data is very low +# resolution so it does not make a lot of sense. +\dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) +} +ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +ano <- MeanDims(ano$ano_exp, 2)[1, , 1, , ] +names(dim(ano)) <- c('time', 'lat', 'lon') +eof <- EOF(ano, sampleData$lat, sampleData$lon) +\dontrun{ +PlotEquiMap(eof$EOFs[1, , ], sampleData$lon, sampleData$lat) +} + +} +\seealso{ +ProjectField, NAO, PlotBoxWhisker +} + diff --git a/man/MeanDims.Rd b/man/MeanDims.Rd index f200023..adff306 100644 --- a/man/MeanDims.Rd +++ b/man/MeanDims.Rd @@ -4,7 +4,7 @@ \alias{MeanDims} \title{Average an array along multiple dimensions} \usage{ -MeanDims(data, dims, na.rm = TRUE, ncores = NULL) +MeanDims(data, dims, na.rm = FALSE, ncores = NULL) } \arguments{ \item{data}{An array to be averaged.} diff --git a/tests/testthat/test-EOF.R b/tests/testthat/test-EOF.R new file mode 100644 index 0000000..0e0aef6 --- /dev/null +++ b/tests/testthat/test-EOF.R @@ -0,0 +1,213 @@ +context("s2dv::EOF tests") + +############################################## + # dat1 + set.seed(1) + dat1 <- array(rnorm(120), dim = c(time = 10, lat = 6, lon = 2)) + lat1 <- seq(10, 30, length.out = 6) + lon1 <- c(10, 12) + + # dat2 + set.seed(1) + dat2 <- array(rnorm(240), dim = c(lat = 6, lon = 2, time = 20)) + lat2 <- seq(-10, 10, length.out = 6) + lon2 <- c(-10, -12) + + # dat3 + set.seed(1) + dat3 <- array(rnorm(480), dim = c(dat = 2, lat = 6, lon = 2, time = 20)) + lat3 <- seq(10, 30, length.out = 6) + lon3 <- c(10, 12) + +############################################## +test_that("1. Input checks", { + + # ano + expect_error( + EOF(c()), + "Parameter 'ano' cannot be NULL." + ) + expect_error( + EOF(c(NA, NA)), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + EOF(list(a = array(rnorm(50), dim = c(dat = 5, sdate = 10)), b = c(1:4))), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + EOF(array(1:10, dim = c(2, 5))), + "Parameter 'ano' must have dimension names." + ) + # time_dim + expect_error( + EOF(dat1, time_dim = 2), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + EOF(dat1, time_dim = c('a','sdate')), + "Parameter 'time_dim' must be a character string." + ) + # space_dim + expect_error( + EOF(dat1, space_dim = 'lat'), + "Parameter 'space_dim' must be a character vector of 2." + ) + expect_error( + EOF(dat1, space_dim = c('latitude', 'longitude')), + "Parameter 'space_dim' is not found in 'ano' dimension." + ) + # lat + expect_error( + EOF(dat1, lat = 1:10), + paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") + ) + expect_error( + EOF(dat1, lat = seq(-100, -80, length.out = 6)), + "Parameter 'lat' must contain values within the range \\[-90, 90\\]." + ) + # lon + expect_error( + EOF(dat1, lat = lat1, lon = c('a', 'b')), + paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") + ) + expect_warning( + EOF(dat1, lat = lat1, lon = c(350, 370)), + "Some 'lon' is out of the range \\[-360, 360\\]." + ) + # neofs + expect_error( + EOF(dat1, lat = lat1, lon = lon1, neofs = -1), + "Parameter 'neofs' must be a positive integer." + ) + # corr + expect_error( + EOF(dat1, lat = lat1, lon = lon1, corr = 0.1), + "Parameter 'corr' must be one logical value." + ) + # ncores + expect_error( + EOF(dat1, lat1, lon1, ncore = 3.5), + "Parameter 'ncores' must be a positive integer." + ) + +}) +############################################## +test_that("2. dat1", { + + expect_equal( + names(EOF(dat1, lon = lon1, lat = lat1)), + c("EOFs", "PCs", "var", "mask", "wght") + ) + expect_equal( + dim(EOF(dat1, lon = lon1, lat = lat1)$EOFs), + c(10, lat = 6, lon = 2) + ) + expect_equal( + dim(EOF(dat1, lon = lon1, lat = lat1)$PCs), + c(10, 10) + ) + expect_equal( + dim(EOF(dat1, lon = lon1, lat = lat1)$var), + c(10) + ) + expect_equal( + dim(EOF(dat1, lon = lon1, lat = lat1)$mask), + c(lat = 6, lon = 2) + ) + expect_equal( + dim(EOF(dat1, lon = lon1, lat = lat1)$wght), + c(lat = 6, lon = 2) + ) + expect_equal( + EOF(dat1, lon = lon1, lat = lat1)$EOFs[1:5], + c(-0.2888168, 0.2792765, 0.1028387, 0.1883640, -0.2896943), + tolerance = 0.0001 + ) + expect_equal( + mean(EOF(dat1, lon = lon1, lat = lat1)$EOFs), + 0.01792716, + tolerance = 0.0001 + ) + expect_equal( + EOF(dat1, lon = lon1, lat = lat1)$PCs[1:5], + c(3.2061306, -0.1692669, 0.5420990, -2.5324441, -0.6143680), + tolerance = 0.0001 + ) + expect_equal( + mean(EOF(dat1, lon = lon1, lat = lat1)$PCs), + 0.08980279, + tolerance = 0.0001 + ) + expect_equal( + EOF(dat1, lon = lon1, lat = lat1)$var[1:5], + array(c(29.247073, 25.364840, 13.247046, 11.121006, 8.662517)), + tolerance = 0.0001 + ) + expect_equal( + sum(EOF(dat1, lon = lon1, lat = lat1)$mask), + 12 + ) + expect_equal( + EOF(dat1, lon = lon1, lat = lat1)$wght[1:5], + c(0.9923748, 0.9850359, 0.9752213, 0.9629039, 0.9480475), + tolerance = 0.0001 + ) + +}) +############################################## +test_that("3. dat2", { + expect_equal( + dim(EOF(dat2, lon = lon2, lat = lat2)$EOFs), + c(12, lat = 6, lon = 2) + ) + expect_equal( + dim(EOF(dat2, lon = lon2, lat = lat2)$PCs), + c(20, 12) + ) + expect_equal( + EOF(dat2, lon = lon2, lat = lat2)$EOFs[1:5], + c(0.33197201, 0.18837900, -0.19697143, 0.08305805, -0.51297585), + tolerance = 0.0001 + ) + expect_equal( + mean(EOF(dat2, lon = lon2, lat = lat2)$EOFs), + 0.02720393, + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("4. dat3", { + expect_equal( + dim(EOF(dat3, lon = lon3, lat = lat3)$EOFs), + c(12, lat = 6, lon = 2, dat = 2) + ) + expect_equal( + dim(EOF(dat3, lon = lon3, lat = lat3)$PCs), + c(20, 12, dat = 2) + ) + expect_equal( + dim(EOF(dat3, lon = lon3, lat = lat3)$var), + c(12, dat = 2) + ) + expect_equal( + dim(EOF(dat3, lon = lon3, lat = lat3)$mask), + c(lat = 6, lon = 2, dat = 2) + ) + expect_equal( + mean(EOF(dat3, lon = lon3, lat = lat3)$EOFs), + 0.01214845, + tolerance = 0.0001 + ) + expect_equal( + EOF(dat3, lon = lon3, lat = lat3)$EOFs[1:5], + c(0.3292733, 0.1787016, -0.3801986, 0.1957160, -0.4377031), + tolerance = 0.0001 + ) + +}) +############################################## -- GitLab From fa11962c6ce77259d58f836e195e281acf2cf370 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 15 Jan 2021 14:40:30 +0100 Subject: [PATCH 02/28] Transfer Ano_CrossValid.R --- NAMESPACE | 1 + R/Ano_CrossValid.R | 221 +++++++++++++++++++++++++++ man/Ano_CrossValid.Rd | 63 ++++++++ tests/testthat/test-Ano_CrossValid.R | 143 +++++++++++++++++ 4 files changed, 428 insertions(+) create mode 100644 R/Ano_CrossValid.R create mode 100644 man/Ano_CrossValid.Rd create mode 100644 tests/testthat/test-Ano_CrossValid.R diff --git a/NAMESPACE b/NAMESPACE index 1eb3cbb..e35f177 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ export(AMV) export(AnimateMap) export(Ano) +export(Ano_CrossValid) export(Clim) export(ColorBar) export(Composite) diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R new file mode 100644 index 0000000..cdbf233 --- /dev/null +++ b/R/Ano_CrossValid.R @@ -0,0 +1,221 @@ +#'Compute anomalies in cross-validation mode +#' +#'Compute the anomalies from the arrays of the experimental and observational +#'data output by subtracting the climatologies computed with a cross-validation +#'technique and a per-pair method. +#' +#'@param exp A named numeric array of experimental data, with at least +#' 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 the time dimension. +#' The default value is 'sdate'. +#'@param dat_dim A character vector indicating the name of the dataset and +#' member dimensions. When calculating the climatology, if data at one +#' startdate (i.e., 'time_dim') is not complete along 'dat_dim', this startdate +#' along 'dat_dim' will be discarded. The default value is +#' "c('dataset', 'member')". +#'@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) when calculating +#' climatology. 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{$ano_exp}{ +#' A numeric array with the same dimensions as 'exp'. The dimension order may +#' change. +#'} +#'\item{$ano_obs}{ +#' A numeric array with the same dimensions as 'obs'.The dimension order may +#' change. +#'} +#' +#'@examples +#'# Load sample data as in Load() example: +#'example(Load) +#'anomalies <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'\dontrun{ +#'PlotAno(anomalies$ano_exp, anomalies$ano_obs, startDates, +#' toptitle = paste('anomalies'), ytitle = c('K', 'K', 'K'), +#' legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano_crossvalid.eps') +#'} +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 'member'), + memb_dim = 'member', memb = 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 have at least dimensions ", + "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.") + } + ## memb + if (!is.logical(memb) | length(memb) > 1) { + stop("Parameter 'memb' must be one logical value.") + } + ## memb_dim + if (!memb) { + 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.") + } + if (!memb_dim %in% dat_dim) { + stop("Parameter 'memb_dim' must be one element in parameter 'dat_dim'.") + } + } + ## 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) + if (any(order_obs != sort(order_obs))) { + obs <- Reorder(obs, order_obs) + } + + #----------------------------------- + # Per-paired method: Remove all sdate if not complete along dat_dim + pos <- rep(0, length(dat_dim)) # dat_dim: [dataset, member] + for (i in 1:length(dat_dim)) { + pos[i] <- which(names(dim(obs)) == dat_dim[i]) + } + outrows_exp <- MeanDims(exp, pos, na.rm = FALSE) + + MeanDims(obs, pos, na.rm = 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_for_clim <- exp + obs_for_clim <- obs + exp_for_clim[which(is.na(outrows_exp))] <- NA + obs_for_clim[which(is.na(outrows_obs))] <- NA + + #----------------------------------- + + res <- Apply(list(exp, obs, exp_for_clim, obs_for_clim), + target_dims = c(time_dim, dat_dim), + fun = .Ano_CrossValid, + memb_dim = memb_dim, memb = memb, + ncores = ncores) + + return(res) +} + +.Ano_CrossValid <- function(exp, obs, exp_for_clim, obs_for_clim, + memb_dim = 'member', memb = TRUE, ncores = NULL) { + # exp: [sdate, dat_dim, memb_dim] + # obs: [sdate, dat_dim, memb_dim] + ano_exp_list <- vector('list', length = dim(exp)[1]) #length: [sdate] + ano_obs_list <- vector('list', length = dim(obs)[1]) + + for (tt in 1:dim(exp)[1]) { #[sdate] + # calculate clim + exp_sub <- Subset(exp_for_clim, 1, c(1:dim(exp)[1])[-tt]) + obs_sub <- Subset(obs_for_clim, 1, c(1:dim(obs)[1])[-tt]) + clim_exp <- apply(exp_sub, c(1:length(dim(exp)))[-1], mean, na.rm = TRUE) # average out time_dim -> [dat, memb] + clim_obs <- apply(obs_sub, c(1:length(dim(obs)))[-1], mean, na.rm = TRUE) + + # ensemble mean + if (!memb) { + if (is.null(dim(clim_exp)) | length(dim(clim_exp)) == 1) { #dim: [member] + clim_exp <- mean(clim_exp, na.rm = TRUE) # a number + 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)) + dim_exp_ori <- dim(clim_exp) + dim_obs_ori <- dim(clim_obs) + + 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] + } + + # Expand it back + clim_exp_tmp <- array(clim_exp, dim = c(dim_exp_ori[pos], dim_exp_ori[-pos])) + clim_obs_tmp <- array(clim_obs, dim = c(dim_obs_ori[pos], dim_obs_ori[-pos])) + # Reorder it back to dim(clim_exp) + tmp <- match(dim_exp_ori, dim(clim_exp_tmp)) + if (any(tmp != sort(tmp))) { + clim_exp <- Reorder(clim_exp_tmp, tmp) + clim_obs <- Reorder(clim_obs_tmp, tmp) + } else { + clim_exp <- clim_exp_tmp + clim_obs <- clim_obs_tmp + } + } + } + # calculate ano + ano_exp_list[[tt]] <- Subset(exp, 1, tt, drop = 'selected') - clim_exp + ano_obs_list[[tt]] <- Subset(obs, 1, tt, drop = 'selected') - clim_obs + } + + ano_exp <- array(unlist(ano_exp_list), dim = c(dim(exp)[-1], dim(exp)[1])) + ano_exp <- Reorder(ano_exp, c(length(dim(exp)), 1:(length(dim(exp)) - 1))) + ano_obs <- array(unlist(ano_obs_list), dim = c(dim(obs)[-1], dim(obs)[1])) + ano_obs <- Reorder(ano_obs, c(length(dim(obs)), 1:(length(dim(obs)) - 1))) + + return(list(ano_exp = ano_exp, ano_obs = ano_obs)) +} diff --git a/man/Ano_CrossValid.Rd b/man/Ano_CrossValid.Rd new file mode 100644 index 0000000..fa56a75 --- /dev/null +++ b/man/Ano_CrossValid.Rd @@ -0,0 +1,63 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Ano_CrossValid.R +\name{Ano_CrossValid} +\alias{Ano_CrossValid} +\title{Compute anomalies in cross-validation mode} +\usage{ +Ano_CrossValid(exp, obs, time_dim = "sdate", dat_dim = c("dataset", + "member"), memb_dim = "member", memb = TRUE, ncores = NULL) +} +\arguments{ +\item{exp}{A named numeric array of experimental data, with at least +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 the time dimension. +The default value is 'sdate'.} + +\item{dat_dim}{A character vector indicating the name of the dataset and +member dimensions. When calculating the climatology, if data at one +startdate (i.e., 'time_dim') is not complete along 'dat_dim', this startdate +along 'dat_dim' will be discarded. The default value is +"c('dataset', 'member')".} + +\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) when calculating +climatology. 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{$ano_exp}{ + A numeric array with the same dimensions as 'exp'. The dimension order may + change. +} +\item{$ano_obs}{ + A numeric array with the same dimensions as 'obs'.The dimension order may + change. +} +} +\description{ +Compute the anomalies from the arrays of the experimental and observational +data output by subtracting the climatologies computed with a cross-validation +technique and a per-pair method. +} +\examples{ +# Load sample data as in Load() example: +example(Load) +anomalies <- Ano_CrossValid(sampleData$mod, sampleData$obs) +\dontrun{ +PlotAno(anomalies$ano_exp, anomalies$ano_obs, startDates, + toptitle = paste('anomalies'), ytitle = c('K', 'K', 'K'), + legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano_crossvalid.eps') +} +} + diff --git a/tests/testthat/test-Ano_CrossValid.R b/tests/testthat/test-Ano_CrossValid.R new file mode 100644 index 0000000..1333f15 --- /dev/null +++ b/tests/testthat/test-Ano_CrossValid.R @@ -0,0 +1,143 @@ +context("s2dv::EOF tests") + +############################################## + # dat1 +set.seed(1) +exp1 <- array(rnorm(60), dim = c(dataset = 2, member = 3, sdate = 5, ftime = 2)) +set.seed(2) +obs1 <- array(rnorm(20), dim = c(dataset = 1, member = 2, sdate = 5, ftime = 2)) + +# dat2 +set.seed(1) +exp2 <- array(rnorm(30), dim = c(member = 3, ftime = 2, sdate = 5)) +set.seed(2) +obs2 <- array(rnorm(20), dim = c(ftime = 2, member = 2, sdate = 5)) + + +############################################## +test_that("1. Input checks", { + + # exp and obs (1) + expect_error( + Ano_CrossValid(c(), c()), + "Parameter 'exp' and 'obs' cannot be NULL." + ) + expect_error( + Ano_CrossValid(c('b'), c('a')), + "Parameter 'exp' and 'obs' must be a numeric array." + ) + expect_error( + Ano_CrossValid(c(1:10), c(2:4)), + paste0("Parameter 'exp' and 'obs' must have at least dimensions ", + "time_dim and dat_dim.") + ) + expect_error( + Ano_CrossValid(array(1:10, dim = c(2, 5)), array(1:4, dim = c(2, 2))), + "Parameter 'exp' and 'obs' must have dimension names." + ) + # time_dim + expect_error( + Ano_CrossValid(exp1, obs1, time_dim = 2), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + Ano_CrossValid(exp1, obs1, time_dim = c('a', 'sdate')), + "Parameter 'time_dim' must be a character string." + ) + # dat_dim + expect_error( + Ano_CrossValid(exp1, obs1, dat_dim = 1), + "Parameter 'dat_dim' must be a character vector." + ) + expect_error( + Ano_CrossValid(exp1, obs1, dat_dim = 'dat'), + "Parameter 'dat_dim' is not found in 'exp' or 'obs' dimension." + ) + # memb + expect_error( + Ano_CrossValid(exp1, obs1, memb = 'member'), + "Parameter 'memb' must be one logical value." + ) + # memb_dim + expect_error( + Ano_CrossValid(exp1, obs1, memb = FALSE, memb_dim = 2), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + Ano_CrossValid(exp1, obs1, memb = FALSE, memb_dim = 'memb'), + "Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension." + ) + expect_error( + Ano_CrossValid(exp1, obs1, memb = FALSE, memb_dim = 'ftime'), + "Parameter 'memb_dim' must be one element in parameter 'dat_dim'." + ) + # ncores + expect_error( + Ano_CrossValid(exp1, obs1, memb = FALSE, ncores = -1), + "Parameter 'ncores' must be a positive integer." + ) + # exp and obs (2) + expect_error( + Ano_CrossValid(exp1, array(1:20, dim = c(dataset = 1, member = 2, sdate = 4, ftime = 2))), + paste0("Parameter 'exp' and 'obs' must have same length of ", + "all dimension expect 'dat_dim'.") + ) + + +}) +############################################## +test_that("2. dat1", { + + expect_equal( + names(Ano_CrossValid(exp1, obs1)), + c("ano_exp", "ano_obs") + ) + expect_equal( + dim(Ano_CrossValid(exp1, obs1)$ano_exp), + c(sdate = 5, dataset = 2, member = 3, ftime = 2) + ) + expect_equal( + Ano_CrossValid(exp1, obs1)$ano_exp[, 1, 2, 2], + c(0.2771331, 1.1675753, -1.0684010, 0.2901759, -0.6664833), + tolerance = 0.0001 + ) + expect_equal( + Ano_CrossValid(exp1, obs1)$ano_obs[, 1, 2, 2], + c(1.7024193, -0.8243579, -2.4136080, 0.5199868, 1.0155598), + tolerance = 0.0001 + ) + expect_equal( + Ano_CrossValid(exp1, obs1, memb = FALSE)$ano_exp[, 1, 2, 2], + c(0.1229714, 0.8496518, -0.9531644, 0.1548713, -0.5264025), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("3. dat2", { + expect_equal( + names(Ano_CrossValid(exp2, obs2, dat_dim = 'member')), + c("ano_exp", "ano_obs") + ) + expect_equal( + dim(Ano_CrossValid(exp2, obs2, dat_dim = 'member')$ano_exp), + c(sdate = 5, member = 3, ftime = 2) + ) + expect_equal( + Ano_CrossValid(exp2, obs2, dat_dim = 'member')$ano_exp[, 2, 2], + c(0.05650631, 1.53434806, -0.37561623, -0.26217217, -0.95306597), + tolerance = 0.0001 + ) + expect_equal( + Ano_CrossValid(exp2, obs2, dat_dim = 'member', memb = FALSE)$ano_exp[, 2, 2], + c(0.34489635, 1.56816273, -0.01926901, -0.09646066, -0.68236823), + tolerance = 0.0001 + ) + +}) + + + + + -- GitLab From f256312753c365fd4d63a1d43aea0e8349ea518d Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 21 Jan 2021 12:11:00 +0100 Subject: [PATCH 03/28] Improve EOF.R --- R/EOF.R | 54 ++++++++++++++++++++++++--------------- man/EOF.Rd | 26 +++++++++++-------- tests/testthat/test-EOF.R | 26 +++++++++++-------- 3 files changed, 64 insertions(+), 42 deletions(-) diff --git a/R/EOF.R b/R/EOF.R index 7dcf911..cf04c42 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -6,13 +6,13 @@ #' #'@param ano A numerical array of anomalies with named dimensions to calculate #' EOF. The dimensions must have at least 'time_dim' and 'space_dim'. +#'@param lat A vector of the latitudes of 'ano'. +#'@param lon A vector of the longitudes of 'ano'. #'@param time_dim A character string indicating the name of the time dimension -#' of 'ano'. +#' of 'ano'. The default value is 'sdate'. #'@param space_dim A vector of two character strings. The first is the dimension #' name of latitude of 'ano' and the second is the dimension name of longitude #' of 'ano'. The default value is c('lat', 'lon'). -#'@param lon A vector of longitudes of 'ano'. -#'@param lat A vector of latitudes of 'ano'. #'@param neofs An integer of the modes to be kept. The default value is 15. #' If time length or the product of latitude length and longitude length is #' less than neofs, neofs is equal to the minimum of the three values. @@ -31,20 +31,23 @@ #'} #'\item{PCs}{ #' An array of principal components with the units of the original field to -#' the power of 2, with dimensions (number of time steps, number of modes). +#' the power of 2, with dimensions (time_dim, number of modes, rest of the +#' dimensions except 'space_dim'). #' \code{PCs} contains already the percentage of explained variance so, #' to reconstruct the original field it's only needed to multiply \code{EOFs} #' by \code{PCs}. #'} #'\item{var}{ -#' A vector indicating the percentage (%) of variance fraction of total -#' variance explained by each mode (number of modes). +#' An array of the percentage (%) of variance fraction of total variance +#' explained by each mode (number of modes). The dimensions are (number of +#' modes, rest of the dimension except 'time_dim' and 'space_dim'). #'} #'\item{mask}{ -#' The mask with dimensions (number of latitudes, number of longitudes). +#' An array of the mask with dimensions (space_dim, rest of the dimension +#' except 'time_dim'). #'} #'\item{wght}{ -#' The weights with dimensions (number of latitudes, number of longitudes). +#' An array of the weights with dimensions (space_dim). #'} #' #'@seealso ProjectField, NAO, PlotBoxWhisker @@ -63,8 +66,9 @@ #' lonmin = -12, lonmax = 40) #'} #'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -#'ano <- MeanDims(ano$ano_exp, 2)[1, , 1, , ] -#'names(dim(ano)) <- c('time', 'lat', 'lon') +#'tmp <- MeanDims(ano$ano_exp, c('dataset', 'member')) +#'ano <- tmp[, 1, ,] +#'names(dim(ano)) <- names(dim(tmp))[-2] #'eof <- EOF(ano, sampleData$lat, sampleData$lon) #'\dontrun{ #'PlotEquiMap(eof$EOFs[1, , ], sampleData$lon, sampleData$lat) @@ -73,7 +77,7 @@ #'@import multiApply #'@importFrom stats sd #'@export -EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), +EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), neofs = 15, corr = FALSE, ncores = NULL) { # Check inputs @@ -127,15 +131,15 @@ EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), } ## ncores if (!is.null(ncores)) { - if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores < 0 | + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | length(ncores) > 1) { stop("Parameter 'ncores' must be a positive integer.") } } - # Replace mask of NAs with 0s for EOF analysis. - ano[!is.finite(ano)] <- 0 +# # Replace mask of NAs with 0s for EOF analysis. +# ano[!is.finite(ano)] <- 0 # Area weighting. Weights for EOF; needed to compute the # fraction of variance explained by each EOFs @@ -149,8 +153,11 @@ EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), wght <- sqrt(wght) res <- Apply(ano, - target_dims = list(c(time_dim, space_dim), - c(time_dim, space_dim)), + target_dims = c(time_dim, space_dim), + output_dims = list(EOFs = c('mode', space_dim), + PCs = c(time_dim, 'mode'), + var = 'mode', + mask = space_dim), fun = .EOF, corr = corr, neofs = neofs, wght = wght, @@ -168,14 +175,17 @@ EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), ny <- dim(ano)[2] nx <- dim(ano)[3] - ano <- ano * InsertDim(wght, 1, nt) - # Build the mask mask <- ano[1, , ] mask[!is.finite(mask)] <- NA mask[is.finite(mask)] <- 1 dim(mask) <- dim(ano)[c(2, 3)] + # Replace mask of NAs with 0s for EOF analysis. + ano[!is.finite(ano)] <- 0 + + ano <- ano * InsertDim(wght, 1, nt) + # The use of the correlation matrix is done under the option corr. if (corr == TRUE) { stdv <- apply(ano, c(2, 3), sd, na.rm = T) @@ -223,10 +233,10 @@ EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), PC <- pca.PCs[, 1:neofs] EOF <- pca.EOFs[1:neofs, ] dim(EOF) <- c(neofs, ny, nx) - + # To sort out crash when neofs=1. if (neofs == 1) { - PC <- InsertDim(PC, 2, 1) + PC <- InsertDim(PC, 2, 1, name = 'new') } # Computation of the % of variance associated with each mode @@ -254,5 +264,9 @@ EOF <- function(ano, lat, lon, time_dim = 'time', space_dim = c('lat', 'lon'), PC[, e] <- eof.pc } + if (neofs == 1) { + var.eof <- as.array(var.eof) + } + return(list(EOFs = EOF, PCs = PC, var = var.eof, mask = mask)) } diff --git a/man/EOF.Rd b/man/EOF.Rd index 782f6cf..a81f779 100644 --- a/man/EOF.Rd +++ b/man/EOF.Rd @@ -4,19 +4,19 @@ \alias{EOF} \title{Area-weighted empirical orthogonal function analysis using SVD} \usage{ -EOF(ano, lat, lon, time_dim = "time", space_dim = c("lat", "lon"), +EOF(ano, lat, lon, time_dim = "sdate", space_dim = c("lat", "lon"), neofs = 15, corr = FALSE, ncores = NULL) } \arguments{ \item{ano}{A numerical array of anomalies with named dimensions to calculate EOF. The dimensions must have at least 'time_dim' and 'space_dim'.} -\item{lat}{A vector of latitudes of 'ano'.} +\item{lat}{A vector of the latitudes of 'ano'.} -\item{lon}{A vector of longitudes of 'ano'.} +\item{lon}{A vector of the longitudes of 'ano'.} \item{time_dim}{A character string indicating the name of the time dimension -of 'ano'.} +of 'ano'. The default value is 'sdate'.} \item{space_dim}{A vector of two character strings. The first is the dimension name of latitude of 'ano' and the second is the dimension name of longitude @@ -42,20 +42,23 @@ A list containing: } \item{PCs}{ An array of principal components with the units of the original field to - the power of 2, with dimensions (number of time steps, number of modes). + the power of 2, with dimensions (time_dim, number of modes, rest of the + dimensions except 'space_dim'). \code{PCs} contains already the percentage of explained variance so, to reconstruct the original field it's only needed to multiply \code{EOFs} by \code{PCs}. } \item{var}{ - A vector indicating the percentage (%) of variance fraction of total - variance explained by each mode (number of modes). + An array of the percentage (%) of variance fraction of total variance + explained by each mode (number of modes). The dimensions are (number of + modes, rest of the dimension except 'time_dim' and 'space_dim'). } \item{mask}{ - The mask with dimensions (number of latitudes, number of longitudes). + An array of the mask with dimensions (space_dim, rest of the dimension + except 'time_dim'). } \item{wght}{ - The weights with dimensions (number of latitudes, number of longitudes). + An array of the weights with dimensions (space_dim). } } \description{ @@ -78,8 +81,9 @@ sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), lonmin = -12, lonmax = 40) } ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -ano <- MeanDims(ano$ano_exp, 2)[1, , 1, , ] -names(dim(ano)) <- c('time', 'lat', 'lon') +tmp <- MeanDims(ano$ano_exp, c('dataset', 'member')) +ano <- tmp[, 1, ,] +names(dim(ano)) <- names(dim(tmp))[-2] eof <- EOF(ano, sampleData$lat, sampleData$lon) \dontrun{ PlotEquiMap(eof$EOFs[1, , ], sampleData$lon, sampleData$lat) diff --git a/tests/testthat/test-EOF.R b/tests/testthat/test-EOF.R index 0e0aef6..e15a971 100644 --- a/tests/testthat/test-EOF.R +++ b/tests/testthat/test-EOF.R @@ -3,19 +3,19 @@ context("s2dv::EOF tests") ############################################## # dat1 set.seed(1) - dat1 <- array(rnorm(120), dim = c(time = 10, lat = 6, lon = 2)) + dat1 <- array(rnorm(120), dim = c(sdate = 10, lat = 6, lon = 2)) lat1 <- seq(10, 30, length.out = 6) lon1 <- c(10, 12) # dat2 set.seed(1) - dat2 <- array(rnorm(240), dim = c(lat = 6, lon = 2, time = 20)) + dat2 <- array(rnorm(240), dim = c(lat = 6, lon = 2, sdate = 20)) lat2 <- seq(-10, 10, length.out = 6) lon2 <- c(-10, -12) # dat3 set.seed(1) - dat3 <- array(rnorm(480), dim = c(dat = 2, lat = 6, lon = 2, time = 20)) + dat3 <- array(rnorm(480), dim = c(dat = 2, lat = 6, lon = 2, sdate = 20)) lat3 <- seq(10, 30, length.out = 6) lon3 <- c(10, 12) @@ -103,15 +103,15 @@ test_that("2. dat1", { ) expect_equal( dim(EOF(dat1, lon = lon1, lat = lat1)$EOFs), - c(10, lat = 6, lon = 2) + c(mode = 10, lat = 6, lon = 2) ) expect_equal( dim(EOF(dat1, lon = lon1, lat = lat1)$PCs), - c(10, 10) + c(sdate = 10, mode = 10) ) expect_equal( dim(EOF(dat1, lon = lon1, lat = lat1)$var), - c(10) + c(mode = 10) ) expect_equal( dim(EOF(dat1, lon = lon1, lat = lat1)$mask), @@ -161,11 +161,11 @@ test_that("2. dat1", { test_that("3. dat2", { expect_equal( dim(EOF(dat2, lon = lon2, lat = lat2)$EOFs), - c(12, lat = 6, lon = 2) + c(mode = 12, lat = 6, lon = 2) ) expect_equal( dim(EOF(dat2, lon = lon2, lat = lat2)$PCs), - c(20, 12) + c(sdate = 20, mode = 12) ) expect_equal( EOF(dat2, lon = lon2, lat = lat2)$EOFs[1:5], @@ -184,21 +184,25 @@ test_that("3. dat2", { test_that("4. dat3", { expect_equal( dim(EOF(dat3, lon = lon3, lat = lat3)$EOFs), - c(12, lat = 6, lon = 2, dat = 2) + c(mode = 12, lat = 6, lon = 2, dat = 2) ) expect_equal( dim(EOF(dat3, lon = lon3, lat = lat3)$PCs), - c(20, 12, dat = 2) + c(sdate = 20, mode = 12, dat = 2) ) expect_equal( dim(EOF(dat3, lon = lon3, lat = lat3)$var), - c(12, dat = 2) + c(mode = 12, dat = 2) ) expect_equal( dim(EOF(dat3, lon = lon3, lat = lat3)$mask), c(lat = 6, lon = 2, dat = 2) ) expect_equal( + dim(EOF(dat3, lon = lon3, lat = lat3)$wght), + c(lat = 6, lon = 2) + ) + expect_equal( mean(EOF(dat3, lon = lon3, lat = lat3)$EOFs), 0.01214845, tolerance = 0.0001 -- GitLab From 66dbbdda180c7b81005daea2ba3ca62e8f698931 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 21 Jan 2021 12:11:30 +0100 Subject: [PATCH 04/28] Transform ProjectField.R --- NAMESPACE | 1 + R/ProjectField.R | 161 ++++++++++++++++++++++++++ man/ProjectField.Rd | 73 ++++++++++++ tests/testthat/test-ProjectField.R | 174 +++++++++++++++++++++++++++++ 4 files changed, 409 insertions(+) create mode 100644 R/ProjectField.R create mode 100644 man/ProjectField.Rd create mode 100644 tests/testthat/test-ProjectField.R diff --git a/NAMESPACE b/NAMESPACE index e35f177..9726809 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -36,6 +36,7 @@ export(PlotLayout) export(PlotMatrix) export(PlotSection) export(PlotStereoMap) +export(ProjectField) export(RMS) export(RMSSS) export(RandomWalkTest) diff --git a/R/ProjectField.R b/R/ProjectField.R new file mode 100644 index 0000000..82a96dd --- /dev/null +++ b/R/ProjectField.R @@ -0,0 +1,161 @@ +#'Project anomalies onto modes of variability +#' +#'Project anomalies onto modes of variability to get the temporal evolution of +#'the EOF mode selected. It returns principal components (PCs) by area-weighted +#'projection onto EOF pattern (from \code{EOF()}). The calculation removes NA +#'and returns NA if the whole spatial pattern is NA. +#' +#'@param ano A numerical array of anomalies with named dimensions. The +#' dimensions must have at least 'time_dim' and 'space_dim'. +#'@param lat A vector of the latitudes of 'ano' to calculate EOF. +#'@param lon A vector of the longitudes of 'ano' to calculate EOF. +#'@param time_dim A character string indicating the name of the time dimension +#' of 'ano'. The default value is 'sdate'. +#'@param space_dim A vector of two character strings. The first is the dimension +#' name of latitude of 'ano' and the second is the dimension name of longitude +#' of 'ano'. The default value is c('lat', 'lon'). +#'@param mode An integer of the variability mode number in the EOF to be +#' projected on. The default value is 1. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return A numerical array of the principal components in the verification +#' format. The dimensions are the same as 'ano' except 'space_dim'. +#' +#'@seealso EOF, NAO, PlotBoxWhisker +#'@examples +#'\dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#'} +#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'mode1_exp <- ProjectField(ano$ano_exp, sampleData$lat, sampleData$lon) +#'mode1_obs <- ProjectField(ano$ano_obs, sampleData$lat, sampleData$lon) +#' +#'\dontrun{ +#' # Plot the forecast and the observation of the first mode for the last year +#' # of forecast +#' sdate_dim_length <- dim(mode1_obs)['sdate'] +#' plot(mode1_obs[sdate_dim_length, 1, 1, ], type = "l", ylim = c(-1, 1), +#' lwd = 2) +#' for (i in 1:dim(mode1_exp)['member']) { +#' par(new = TRUE) +#' plot(mode1_exp[sdate_dim_length, 1, i, ], type = "l", col = rainbow(10)[i], +#' ylim = c(-15000, 15000)) +#' } +#'} +#' +#'@export +ProjectField <- function(ano, lat, lon, time_dim = 'sdate', + space_dim = c('lat', 'lon'), mode = 1, ncores = NULL) { + + # Check inputs + ## ano + if (is.null(ano)) { + stop("Parameter 'ano' cannot be NULL.") + } + if (!is.numeric(ano)) { + stop("Parameter 'ano' must be a numeric array.") + } + if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + stop("Parameter 'ano' must have dimension names.") + } + if (any(lon > 360 | lon < -360)) { + warning("Some 'lon' is out of the range [-360, 360].") + } + ## 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(ano))) { + stop("Parameter 'time_dim' is not found in 'ano' dimension.") + } + ## space_dim + if (!is.character(space_dim) | length(space_dim) != 2) { + stop("Parameter 'space_dim' must be a character vector of 2.") + } + if (any(!space_dim %in% names(dim(ano)))) { + stop("Parameter 'space_dim' is not found in 'ano' dimension.") + } + ## lat + if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { + stop(paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.")) + } + if (any(lat > 90 | lat < -90)) { + stop("Parameter 'lat' must contain values within the range [-90, 90].") + } + ## lon + if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { + stop(paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.")) + } + if (any(lon > 360 | lon < -360)) { + warning("Some 'lon' is out of the range [-360, 360].") + } + ## mode + if (!is.numeric(mode) | mode %% 1 != 0 | mode < 0 | length(mode) > 1) { + stop("Parameter 'mode' must be a positive integer.") + } + ## 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.") + } + } + +#------------------------------------------------------- + + # Compute EOF + eof <- EOF(ano = ano, lat = lat, lon = lon, + time_dim = time_dim, space_dim = space_dim, + neofs = mode) + + if (mode > dim(eof$EOFs)[1]) { + stop(paste0("Parameter 'mode' is greater than the number of available ", + "modes in EOF.")) + } + + # Keep the chosen mode + eof_mode <- Subset(eof$EOFs, 'mode', mode, drop = 'selected') + + res <- Apply(list(ano, eof_mode, eof$wght), + target_dims = list(c(space_dim, time_dim), + c(space_dim), + c(space_dim)), + output_dims = time_dim, + fun = .ProjectField, + ncores = ncores)$output1 + + return(res) +} + + +.ProjectField <- function(ano, eof_mode, wght) { + # ano: [lat, lon, sdate] + # eof_mode: [lat, lon] + # wght: [lat, lon] + dim_time <- dim(ano)[3] + + # Initialization of pc.ver. + pc.ver <- array(NA, dim = dim_time) #[sdate] + + # Weigths + e.1 <- eof_mode * wght + + ano <- ano * InsertDim(wght, 3, dim_time) + na <- apply(ano, 3, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA + tmp <- ano * InsertDim(e.1, 3, dim_time) # [lat, lon, sdate] + pc.ver <- apply(tmp, 3, sum, na.rm = TRUE) + pc.ver[which(is.na(na))] <- NA + + return(pc.ver) +} + diff --git a/man/ProjectField.Rd b/man/ProjectField.Rd new file mode 100644 index 0000000..198db05 --- /dev/null +++ b/man/ProjectField.Rd @@ -0,0 +1,73 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/ProjectField.R +\name{ProjectField} +\alias{ProjectField} +\title{Project anomalies onto modes of variability} +\usage{ +ProjectField(ano, lat, lon, time_dim = "sdate", space_dim = c("lat", "lon"), + mode = 1, ncores = NULL) +} +\arguments{ +\item{ano}{A numerical array of anomalies with named dimensions. The +dimensions must have at least 'time_dim' and 'space_dim'.} + +\item{lat}{A vector of the latitudes of 'ano' to calculate EOF.} + +\item{lon}{A vector of the longitudes of 'ano' to calculate EOF.} + +\item{time_dim}{A character string indicating the name of the time dimension +of 'ano'. The default value is 'sdate'.} + +\item{space_dim}{A vector of two character strings. The first is the dimension +name of latitude of 'ano' and the second is the dimension name of longitude +of 'ano'. The default value is c('lat', 'lon').} + +\item{mode}{An integer of the variability mode number in the EOF to be +projected on. The default value is 1.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A numerical array of the principal components in the verification + format. The dimensions are the same as 'ano' except 'space_dim'. +} +\description{ +Project anomalies onto modes of variability to get the temporal evolution of +the EOF mode selected. It returns principal components (PCs) by area-weighted +projection onto EOF pattern (from \code{EOF()}). The calculation removes NA +and returns NA if the whole spatial pattern is NA. +} +\examples{ +\dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) +} +ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +mode1_exp <- ProjectField(ano$ano_exp, sampleData$lat, sampleData$lon) +mode1_obs <- ProjectField(ano$ano_obs, sampleData$lat, sampleData$lon) + +\dontrun{ + # Plot the forecast and the observation of the first mode for the last year + # of forecast + sdate_dim_length <- dim(mode1_obs)['sdate'] + plot(mode1_obs[sdate_dim_length, 1, 1, ], type = "l", ylim = c(-1, 1), + lwd = 2) + for (i in 1:dim(mode1_exp)['member']) { + par(new = TRUE) + plot(mode1_exp[sdate_dim_length, 1, i, ], type = "l", col = rainbow(10)[i], + ylim = c(-15000, 15000)) + } +} + +} +\seealso{ +EOF, NAO, PlotBoxWhisker +} + diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R new file mode 100644 index 0000000..eef3692 --- /dev/null +++ b/tests/testthat/test-ProjectField.R @@ -0,0 +1,174 @@ +context("s2dv::ProjectField tests") + +############################################## + # dat1 + set.seed(1) + dat1 <- array(rnorm(120), dim = c(sdate = 10, lat = 6, lon = 2)) + lat1 <- seq(10, 30, length.out = 6) + lon1 <- c(10, 12) + + # dat2 + set.seed(1) + dat2 <- array(rnorm(48), dim = c(dat = 1, memb = 1, sdate = 6, ftime = 1, lat = 4, lon = 2)) + lat2 <- seq(10, 30, length.out = 4) + lon2 <- c(-5, 5) + + # dat3 + dat3 <- dat2 + dat3[1, 1, 1, 1, , ] <- NA + names(dim(dat3)) <- names(dim(dat2)) + lat3 <- seq(10, 30, length.out = 4) + lon3 <- c(-5, 5) + + # dat4 + set.seed(1) + dat4 <- array(rnorm(288), dim = c(dat = 1, memb = 2, sdate = 6, ftime = 3, lat = 4, lon = 2)) + lat4 <- seq(-10, -30, length.out = 4) + lon4 <- c(350, 355) + + +############################################## +test_that("1. Input checks", { + + # ano + expect_error( + ProjectField(c()), + "Parameter 'ano' cannot be NULL." + ) + expect_error( + ProjectField(c(NA, NA)), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + ProjectField(list(a = array(rnorm(50), dim = c(dat = 5, sdate = 10)), b = c(1:4))), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + ProjectField(array(1:10, dim = c(2, 5))), + "Parameter 'ano' must have dimension names." + ) + # lat + expect_error( + ProjectField(dat1, lat = 1:10, lon = lon1), + paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") + ) + expect_error( + ProjectField(dat1, lat = seq(-100, -80, length.out = 6), lon = lon1), + "Parameter 'lat' must contain values within the range \\[-90, 90\\]." + ) + # lon + expect_error( + ProjectField(dat1, lat = lat1, lon = c('a', 'b')), + paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") + ) + expect_warning( + EOF(dat1, lat = lat1, lon = c(350, 370)), + "Some 'lon' is out of the range \\[-360, 360\\]." + ) + # time_dim + expect_error( + ProjectField(dat1, lat1, lon1, time_dim = 2), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + ProjectField(dat1, lat1, lon1, time_dim = c('a','sdate')), + "Parameter 'time_dim' must be a character string." + ) + # space_dim + expect_error( + ProjectField(dat1, lat1, lon1, space_dim = 'lat'), + "Parameter 'space_dim' must be a character vector of 2." + ) + expect_error( + ProjectField(dat1, lat1, lon1, space_dim = c('latitude', 'longitude')), + "Parameter 'space_dim' is not found in 'ano' dimension." + ) + # mode + expect_error( + ProjectField(dat1, lat = lat1, lon = lon1, mode = -1), + "Parameter 'mode' must be a positive integer." + ) + expect_error( + ProjectField(dat1, lat = lat1, lon = lon1, mode = 15), + paste0("Parameter 'mode' is greater than the number of available ", + "modes in EOF.") + ) + # ncores + expect_error( + ProjectField(dat1, lat1, lon1, ncore = 3.5), + "Parameter 'ncores' must be a positive integer." + ) + +}) +############################################## +test_that("2. dat1", { + + expect_equal( + dim(ProjectField(dat1, lon = lon1, lat = lat1)), + c(sdate = 10) + ) + expect_equal( + as.vector(ProjectField(dat1, lon = lon1, lat = lat1))[1:5], + c(3.2061306, -0.1692669, 0.5420990, -2.5324441, -0.6143680), + tolerance = 0.0001 + ) + expect_equal( + as.vector(ProjectField(dat1, lon = lon1, lat = lat1, mode = 10))[1:5], + c(-0.24848299, -0.19311118, -0.16951195, -0.10000207, 0.04554693), + tolerance = 0.0001 + ) + +}) +############################################## +test_that("3. dat2", { + expect_equal( + dim(ProjectField(dat2, lon = lon2, lat = lat2)), + c(sdate = 6, dat = 1, memb = 1, ftime = 1) + ) + expect_equal( + ProjectField(dat2, lon = lon2, lat = lat2)[1:6], + c(0.00118771, -1.20872474, -0.00821559, -2.06064916, -0.19245169, 2.26026937), + tolerance = 0.0001 + ) + expect_equal( + mean(ProjectField(dat2, lon = lon2, lat = lat2, mode = 6)), + 0.1741076, + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("4. dat3", { + expect_equal( + dim(ProjectField(dat3, lon = lon3, lat = lat3)), + c(sdate = 6, dat = 1, memb = 1, ftime = 1) + ) + expect_equal( + ProjectField(dat3, lon = lon3, lat = lat3)[1:6], + c(NA, 0, 0, 0, 0, 0), + tolerance = 0.0001 + ) + +}) +############################################## +test_that("5. dat4", { + expect_equal( + dim(ProjectField(dat4, lon = lon4, lat = lat4)), + c(sdate = 6, dat = 1, memb = 2, ftime = 3) + ) + expect_equal( + mean(ProjectField(dat4, lon = lon4, lat = lat4)), + -0.1179755, + tolerance = 0.0001 + ) + expect_equal( + ProjectField(dat4, lon = lon4, lat = lat4)[, 1, 2, 2], + c(1.73869255, -2.58156427, 0.05340228, -0.53610350, -3.13985059, 1.58785066), + tolerance = 0.0001 + ) + +}) +############################################## -- GitLab From f22e5c1feb972d18af0964e5c908d1f518daefb7 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 3 Feb 2021 22:30:19 +0100 Subject: [PATCH 05/28] Use EOF() output as input instead of calculating EOF internally. --- R/ProjectField.R | 82 +++++++++++++++++++++++++++++++----------------- 1 file changed, 53 insertions(+), 29 deletions(-) diff --git a/R/ProjectField.R b/R/ProjectField.R index 82a96dd..16ab178 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -7,8 +7,9 @@ #' #'@param ano A numerical array of anomalies with named dimensions. The #' dimensions must have at least 'time_dim' and 'space_dim'. -#'@param lat A vector of the latitudes of 'ano' to calculate EOF. -#'@param lon A vector of the longitudes of 'ano' to calculate EOF. +#'@param eof A list contains at least 'EOFs' and 'wght', which are both arrays. +#' 'EOFs' has dimensions same as 'ano' except 'EOFs' has 'mode' and 'ano' has +#' time_dim. 'wght' has dimensions space_dim. It can be generated by EOF(). #'@param time_dim A character string indicating the name of the time dimension #' of 'ano'. The default value is 'sdate'. #'@param space_dim A vector of two character strings. The first is the dimension @@ -35,8 +36,10 @@ #' lonmin = -12, lonmax = 40) #'} #'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -#'mode1_exp <- ProjectField(ano$ano_exp, sampleData$lat, sampleData$lon) -#'mode1_obs <- ProjectField(ano$ano_obs, sampleData$lat, sampleData$lon) +#'eof_exp <- EOF(ano$ano_exp, sampleData$lat, sampleData$lon) +#'eof_obs <- EOF(ano$ano_obs, sampleData$lat, sampleData$lon) +#'mode1_exp <- ProjectField(ano$ano_exp, eof_exp) +#'mode1_obs <- ProjectField(ano$ano_obs, eof_obs) #' #'\dontrun{ #' # Plot the forecast and the observation of the first mode for the last year @@ -52,7 +55,7 @@ #'} #' #'@export -ProjectField <- function(ano, lat, lon, time_dim = 'sdate', +ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon'), mode = 1, ncores = NULL) { # Check inputs @@ -66,8 +69,21 @@ ProjectField <- function(ano, lat, lon, time_dim = 'sdate', if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { stop("Parameter 'ano' must have dimension names.") } - if (any(lon > 360 | lon < -360)) { - warning("Some 'lon' is out of the range [-360, 360].") + ## eof (1) + if (is.null(eof)) { + stop("Parameter 'eof' cannot be NULL.") + } + if (!is.list(eof)) { + stop("Parameter 'eof' must be a list generated by EOF().") + } + if (!all(c('EOFs', 'wght') %in% names(eof))) { + stop("Parameter 'eof' must contain 'EOFs' and 'wght' generated by EOF().") + } + if (!is.numeric(eof$EOFs) || !is.array(eof$EOFs)) { + stop("The component 'EOFs' of parameter 'eof' must be a numeric array.") + } + if (!is.numeric(eof$wght) || !is.array(eof$wght)) { + stop("The component 'wght' of parameter 'eof' must be a numeric array.") } ## time_dim if (!is.character(time_dim) | length(time_dim) > 1) { @@ -83,26 +99,44 @@ ProjectField <- function(ano, lat, lon, time_dim = 'sdate', if (any(!space_dim %in% names(dim(ano)))) { stop("Parameter 'space_dim' is not found in 'ano' dimension.") } - ## lat - if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { - stop(paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'ano'.")) + ## eof (2) + if (!all(space_dim %in% names(dim(eof$EOFs))) | + !'mode' %in% names(dim(eof$EOFs))) { + stop(paste0("The component 'EOFs' of parameter 'eof' must be an array ", + "with dimensions named as parameter 'space_dim' and 'mode'.")) } - if (any(lat > 90 | lat < -90)) { - stop("Parameter 'lat' must contain values within the range [-90, 90].") + # eof$EOFs should have the same dimensions as 'ano' except that ano doesn't have 'mode' and EOFs doesn't have time_dim + common_dim_ano <- dim(ano)[-which(names(dim(ano)) == time_dim)] + common_dim_eofs <- dim(eof$EOFs)[-which(names(dim(eof$EOFs)) == 'mode')] + raise_error <- FALSE + if (length(common_dim_ano) != length(common_dim_eofs)) { + raise_error <- TRUE + } else if (!all(names(common_dim_ano) %in% names(common_dim_eofs)) | + !all(names(common_dim_eofs) %in% names(common_dim_ano))) { + raise_error <- TRUE + } else { + order <- match(names(common_dim_ano), names(common_dim_eofs)) + if (any(common_dim_eofs[order] != common_dim_ano)) { + raise_error <- TRUE + } } - ## lon - if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { - stop(paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'ano'.")) + if (raise_error) { + stop(paste0("The component 'EOFs' of parameter 'eof' must have the ", + "same dimensions as 'ano' except that 'ano' does not have ", + "'mode' and 'EOFs' does not have time_dim.")) } - if (any(lon > 360 | lon < -360)) { - warning("Some 'lon' is out of the range [-360, 360].") + if (length(dim(eof$wght)) != 2 | !all(names(dim(eof$wght)) %in% space_dim)) { + stop(paste0("The component 'wght' of parameter 'eof' must be an array ", + "with dimensions named as parameter 'space_dim'.")) } ## mode if (!is.numeric(mode) | mode %% 1 != 0 | mode < 0 | length(mode) > 1) { stop("Parameter 'mode' must be a positive integer.") } + if (mode > dim(eof$EOFs)['mode']) { + stop(paste0("Parameter 'mode' is greater than the number of available ", + "modes in EOF.")) + } ## ncores if (!is.null(ncores)) { if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | @@ -113,16 +147,6 @@ ProjectField <- function(ano, lat, lon, time_dim = 'sdate', #------------------------------------------------------- - # Compute EOF - eof <- EOF(ano = ano, lat = lat, lon = lon, - time_dim = time_dim, space_dim = space_dim, - neofs = mode) - - if (mode > dim(eof$EOFs)[1]) { - stop(paste0("Parameter 'mode' is greater than the number of available ", - "modes in EOF.")) - } - # Keep the chosen mode eof_mode <- Subset(eof$EOFs, 'mode', mode, drop = 'selected') -- GitLab From e89c260638b226856f9125a0994a9592dc284850 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 3 Feb 2021 22:30:48 +0100 Subject: [PATCH 06/28] Use EOF() output as input instead of calculating EOF internally. --- tests/testthat/test-ProjectField.R | 94 ++++++++++++++++++++---------- 1 file changed, 62 insertions(+), 32 deletions(-) diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R index eef3692..c306a7a 100644 --- a/tests/testthat/test-ProjectField.R +++ b/tests/testthat/test-ProjectField.R @@ -6,12 +6,14 @@ context("s2dv::ProjectField tests") dat1 <- array(rnorm(120), dim = c(sdate = 10, lat = 6, lon = 2)) lat1 <- seq(10, 30, length.out = 6) lon1 <- c(10, 12) + eof1 <- EOF(dat1, lat1, lon1) # dat2 set.seed(1) dat2 <- array(rnorm(48), dim = c(dat = 1, memb = 1, sdate = 6, ftime = 1, lat = 4, lon = 2)) lat2 <- seq(10, 30, length.out = 4) lon2 <- c(-5, 5) + eof2 <- EOF(dat2, lat2, lon2) # dat3 dat3 <- dat2 @@ -19,13 +21,14 @@ context("s2dv::ProjectField tests") names(dim(dat3)) <- names(dim(dat2)) lat3 <- seq(10, 30, length.out = 4) lon3 <- c(-5, 5) + eof3 <- EOF(dat3, lat3, lon3) # dat4 set.seed(1) dat4 <- array(rnorm(288), dim = c(dat = 1, memb = 2, sdate = 6, ftime = 3, lat = 4, lon = 2)) lat4 <- seq(-10, -30, length.out = 4) lon4 <- c(350, 355) - + eof4 <- EOF(dat4, lat4, lon4) ############################################## test_that("1. Input checks", { @@ -47,57 +50,84 @@ test_that("1. Input checks", { ProjectField(array(1:10, dim = c(2, 5))), "Parameter 'ano' must have dimension names." ) - # lat + # eof expect_error( - ProjectField(dat1, lat = 1:10, lon = lon1), - paste0("Parameter 'lat' must be a numeric vector with the same ", - "length as the latitude dimension of 'ano'.") + ProjectField(dat1, c()), + "Parameter 'eof' cannot be NULL." ) expect_error( - ProjectField(dat1, lat = seq(-100, -80, length.out = 6), lon = lon1), - "Parameter 'lat' must contain values within the range \\[-90, 90\\]." + ProjectField(dat1, c(1, 2, 3)), + "Parameter 'eof' must be a list generated by EOF()." ) - # lon expect_error( - ProjectField(dat1, lat = lat1, lon = c('a', 'b')), - paste0("Parameter 'lon' must be a numeric vector with the same ", - "length as the longitude dimension of 'ano'.") + ProjectField(dat1, list(a = 1)), + "Parameter 'eof' must contain 'EOFs' and 'wght' generated by EOF()." ) - expect_warning( - EOF(dat1, lat = lat1, lon = c(350, 370)), - "Some 'lon' is out of the range \\[-360, 360\\]." + eof_fake <- list(EOFs = 'a', wght = 1:10) + expect_error( + ProjectField(dat1, eof_fake), + "The component 'EOFs' of parameter 'eof' must be a numeric array." + ) + eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 2, lon = 5)), + wght = c(1:10)) + expect_error( + ProjectField(dat1, eof_fake), + "The component 'wght' of parameter 'eof' must be a numeric array." ) # time_dim expect_error( - ProjectField(dat1, lat1, lon1, time_dim = 2), + ProjectField(dat1, eof1, time_dim = 2), "Parameter 'time_dim' must be a character string." ) expect_error( - ProjectField(dat1, lat1, lon1, time_dim = c('a','sdate')), + ProjectField(dat1, eof1, time_dim = c('a','sdate')), "Parameter 'time_dim' must be a character string." ) # space_dim expect_error( - ProjectField(dat1, lat1, lon1, space_dim = 'lat'), + ProjectField(dat1, eof1, space_dim = 'lat'), "Parameter 'space_dim' must be a character vector of 2." ) expect_error( - ProjectField(dat1, lat1, lon1, space_dim = c('latitude', 'longitude')), + ProjectField(dat1, eof1, space_dim = c('latitude', 'longitude')), "Parameter 'space_dim' is not found in 'ano' dimension." ) + # eof (2) + eof_fake <- list(EOFs = array(rnorm(10), dim = c(lat = 2, lon = 5)), + wght = array(rnorm(10), dim = c(lat = 2, lon = 5))) + expect_error( + ProjectField(dat1, eof_fake), + paste0("The component 'EOFs' of parameter 'eof' must be an array ", + "with dimensions named as parameter 'space_dim' and 'mode'.") + ) + eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 6, lon = 3)), + wght = array(rnorm(10), dim = c(lat = 6, lon = 2))) + expect_error( + ProjectField(dat1, eof_fake), + paste0("The component 'EOFs' of parameter 'eof' must have the ", + "same dimensions as 'ano' except that 'ano' does not have ", + "'mode' and 'EOFs' does not have time_dim.") + ) + eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 6, lon = 2)), + wght = array(rnorm(10), dim = c(level = 6, lon = 2))) + expect_error( + ProjectField(dat1, eof_fake), + paste0("The component 'wght' of parameter 'eof' must be an array ", + "with dimensions named as parameter 'space_dim'.") + ) # mode expect_error( - ProjectField(dat1, lat = lat1, lon = lon1, mode = -1), + ProjectField(dat1, eof1, mode = -1), "Parameter 'mode' must be a positive integer." ) expect_error( - ProjectField(dat1, lat = lat1, lon = lon1, mode = 15), + ProjectField(dat1, eof1, mode = 15), paste0("Parameter 'mode' is greater than the number of available ", "modes in EOF.") ) # ncores expect_error( - ProjectField(dat1, lat1, lon1, ncore = 3.5), + ProjectField(dat1, eof1, ncore = 3.5), "Parameter 'ncores' must be a positive integer." ) @@ -106,16 +136,16 @@ test_that("1. Input checks", { test_that("2. dat1", { expect_equal( - dim(ProjectField(dat1, lon = lon1, lat = lat1)), + dim(ProjectField(dat1, eof = eof1)), c(sdate = 10) ) expect_equal( - as.vector(ProjectField(dat1, lon = lon1, lat = lat1))[1:5], + as.vector(ProjectField(dat1, eof1))[1:5], c(3.2061306, -0.1692669, 0.5420990, -2.5324441, -0.6143680), tolerance = 0.0001 ) expect_equal( - as.vector(ProjectField(dat1, lon = lon1, lat = lat1, mode = 10))[1:5], + as.vector(ProjectField(dat1, eof1, mode = 10))[1:5], c(-0.24848299, -0.19311118, -0.16951195, -0.10000207, 0.04554693), tolerance = 0.0001 ) @@ -124,16 +154,16 @@ test_that("2. dat1", { ############################################## test_that("3. dat2", { expect_equal( - dim(ProjectField(dat2, lon = lon2, lat = lat2)), + dim(ProjectField(dat2, eof2)), c(sdate = 6, dat = 1, memb = 1, ftime = 1) ) expect_equal( - ProjectField(dat2, lon = lon2, lat = lat2)[1:6], + ProjectField(dat2, eof2)[1:6], c(0.00118771, -1.20872474, -0.00821559, -2.06064916, -0.19245169, 2.26026937), tolerance = 0.0001 ) expect_equal( - mean(ProjectField(dat2, lon = lon2, lat = lat2, mode = 6)), + mean(ProjectField(dat2, eof2, mode = 6)), 0.1741076, tolerance = 0.0001 ) @@ -143,11 +173,11 @@ test_that("3. dat2", { ############################################## test_that("4. dat3", { expect_equal( - dim(ProjectField(dat3, lon = lon3, lat = lat3)), + dim(ProjectField(dat3, eof3)), c(sdate = 6, dat = 1, memb = 1, ftime = 1) ) expect_equal( - ProjectField(dat3, lon = lon3, lat = lat3)[1:6], + ProjectField(dat3, eof3)[1:6], c(NA, 0, 0, 0, 0, 0), tolerance = 0.0001 ) @@ -156,16 +186,16 @@ test_that("4. dat3", { ############################################## test_that("5. dat4", { expect_equal( - dim(ProjectField(dat4, lon = lon4, lat = lat4)), + dim(ProjectField(dat4, eof4)), c(sdate = 6, dat = 1, memb = 2, ftime = 3) ) expect_equal( - mean(ProjectField(dat4, lon = lon4, lat = lat4)), + mean(ProjectField(dat4, eof4)), -0.1179755, tolerance = 0.0001 ) expect_equal( - ProjectField(dat4, lon = lon4, lat = lat4)[, 1, 2, 2], + ProjectField(dat4, eof4)[, 1, 2, 2], c(1.73869255, -2.58156427, 0.05340228, -0.53610350, -3.13985059, 1.58785066), tolerance = 0.0001 ) -- GitLab From 9b3915ae3b00c1b2c2afed8122ba92598d6ea4ba Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 5 Feb 2021 09:24:22 +0100 Subject: [PATCH 07/28] Transform NAO.R and PlotBoxWhisker.R from s2dverification --- R/NAO.R | 414 ++++++++++++++++++++++++++++++++++++++ R/PlotBoxWhisker.R | 242 ++++++++++++++++++++++ man/NAO.Rd | 124 ++++++++++++ man/PlotBoxWhisker.Rd | 146 ++++++++++++++ tests/testthat/test-NAO.R | 222 ++++++++++++++++++++ 5 files changed, 1148 insertions(+) create mode 100644 R/NAO.R create mode 100644 R/PlotBoxWhisker.R create mode 100644 man/NAO.Rd create mode 100644 man/PlotBoxWhisker.Rd create mode 100644 tests/testthat/test-NAO.R diff --git a/R/NAO.R b/R/NAO.R new file mode 100644 index 0000000..a73536a --- /dev/null +++ b/R/NAO.R @@ -0,0 +1,414 @@ +#'Compute the North Atlantic Oscillation (NAO) Index +#' +#'Compute the North Atlantic Oscillation (NAO) index based on the leading EOF +#'of the sea level pressure (SLP) anomalies over the north Atlantic region +#'(20N-80N, 80W-40E). The PCs are obtained by projecting the forecast and +#'observed anomalies onto the observed EOF pattern (Pobs) or the forecast +#'anomalies onto the EOF pattern of the other years of the forecast (Pmod). +#'By default (ftime_avg = 2:4) NAO() computes the NAO index for 1-month +#'lead seasonal forecasts that can be plotted with PlotBoxWhisker(). It returns +#'cross-validated PCs of the NAO index for forecast (exp) and observations +#'(obs) based on the leading EOF pattern. +#' +#'@param exp A named numeric array of North Atlantic SLP (20N-80N, 80W-40E) +#' forecast anomalies from \code{Ano()} or \code{Ano_CrossValid()} with +#' dimensions 'time_dim', 'memb_dim', 'ftime_dim', and 'space_dim' at least. +#' If only NAO of observational data needs to be computed, this parameter can +#' be left to NULL. The default value is NULL. +#'@param obs A named numeric array of North Atlantic SLP (20N-80N, 80W-40E) +#' observed anomalies from \code{Ano()} or \code{Ano_CrossValid()} with +#' dimensions 'time_dim', 'memb_dim', 'ftime_dim', and 'space_dim' at least. +#' If only NAO of experimental data needs to be computed, this parameter can +#' be left to NULL. The default value is NULL. +#'@param lat A vector of the latitudes of 'exp' and 'obs'. +#'@param lon A vector of the longitudes of 'exp' and 'obs'. +#'@param time_dim A character string indicating the name of the time dimension +#' of 'exp' and 'obs'. The default value is 'sdate'. +#'@param memb_dim A character string indicating the name of the member +#' dimension of 'exp' and 'obs'. The default value is 'member'. +#'@param space_dim A vector of two character strings. The first is the dimension +#' name of latitude of 'ano' and the second is the dimension name of longitude +#' of 'ano'. The default value is c('lat', 'lon'). +#'@param ftime_dim A character string indicating the name of the forecast time +#' dimension of 'exp' and 'obs'. The default value is 'ftime'. +#'@param ftime_avg A numeric vector of the forecast time steps to average +#' across the target period. The default value is 2:4, i.e., from 2nd to 4th +#' forecast time steps. +#'@param obsproj A logical value indicating whether to compute the NAO index by +#' projecting the forecast anomalies onto the leading EOF of observational +#' reference (TRUE) or compute the NAO by first computing the leading +#' EOF of the forecast anomalies (in cross-validation mode, i.e. leaving the +#' year you are evaluating out), and then projecting forecast anomalies onto +#' this EOF (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 which contains: +#'\item{exp}{ +#' A numeric array of forecast NAO index in verification format with the same +#' dimensions as 'exp' except space_dim and ftime_dim. +#' } +#'\item{obs}{ +#' A numeric array of observed NAO index in verification format with the same +#' dimensions as 'obs' except space_dim and ftime_dim. +#'} +#' +#'@references +#'Doblas-Reyes, F.J., Pavan, V. and Stephenson, D. (2003). The skill of +#' multi-model seasonal forecasts of the wintertime North Atlantic +#' Oscillation. Climate Dynamics, 21, 501-514. +#' DOI: 10.1007/s00382-003-0350-4 +#' +#'@examples +#' \dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, 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 +#'# the NAO region directly. +#'sampleData$lon[] <- c(40, 280, 340) +#'sampleData$lat[] <- c(20, 80) +#' } +#' +#'# Now ready to compute the EOFs and project on, for example, the first +#'# variability mode. +#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'# Note that computing the NAO over the region for which there is available +#'# example data is not the full NAO area: NAO() will raise a warning. +#'nao <- NAO(ano$exp, ano$obs, sampleData$lat, sampleData$lon) +#'# Finally plot the NAO index +#' \dontrun{ +#'nao$exp <- Reorder(nao$exp, c(2, 1)) +#'nao$obs <- Reorder(nao$obs, c(2, 1)) +#'PlotBoxWhisker(nao$exp, nao$obs, "NAO index, DJF", "NAO index (PC1) TOS", +#' monini = 12, yearini = 1985, freq = 1, "Exp. A", "Obs. X") +#' } +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', + memb_dim = 'member', space_dim = c('lat', 'lon'), + ftime_dim = 'ftime', ftime_avg = 2:4, + obsproj = TRUE, ncores = NULL) { + + # Check inputs + ## exp and obs (1) + if (is.null(obs) & is.null(exp)) { + stop("Parameter 'exp' and 'obs' cannot both be NULL.") + } + if (!is.null(exp)) { + if (!is.numeric(exp)) { + stop("Parameter 'exp' must be a numeric array.") + } + if (is.null(dim(exp))) { + stop(paste0("Parameter 'exp' and must have at least dimensions ", + "time_dim, memb_dim, space_dim, and ftime_dim.")) + } + if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0)) { + stop("Parameter 'exp' must have dimension names.") + } + } + if (!is.null(obs)) { + if (!is.numeric(obs)) { + stop("Parameter 'obs' must be a numeric array.") + } + if (is.null(dim(obs))) { + stop(paste0("Parameter 'obs' and must have at least dimensions ", + "time_dim, memb_dim, space_dim, and ftime_dim.")) + } + if(any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { + stop("Parameter 'obs' 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 (!is.null(exp)) { + if (!time_dim %in% names(dim(exp))) { + stop("Parameter 'time_dim' is not found in 'exp' or 'obs' dimension.") + } + } + if (!is.null(obs)) { + if (!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 (!is.null(exp)) { + if (!memb_dim %in% names(dim(exp))) { + stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + } + } + if (!is.null(obs)) { + if (!memb_dim %in% names(dim(obs))) { + stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + } + } + ## space_dim + if (!is.character(space_dim) | length(space_dim) != 2) { + stop("Parameter 'space_dim' must be a character vector of 2.") + } + if (!is.null(exp)) { + if (any(!space_dim %in% names(dim(exp)))) { + stop("Parameter 'space_dim' is not found in 'exp' or 'obs' dimension.") + } + } + if (!is.null(obs)) { + if (any(!space_dim %in% names(dim(obs)))) { + stop("Parameter 'space_dim' is not found in 'exp' or 'obs' dimension.") + } + } + ## ftime_dim + if (!is.character(ftime_dim) | length(ftime_dim) > 1) { + stop("Parameter 'ftime_dim' must be a character string.") + } + if (!is.null(exp)) { + if (!ftime_dim %in% names(dim(exp))) { + stop("Parameter 'ftime_dim' is not found in 'exp' or 'obs' dimension.") + } + } + if (!is.null(obs)) { + if (!ftime_dim %in% names(dim(obs))) { + stop("Parameter 'ftime_dim' is not found in 'exp' or 'obs' dimension.") + } + } + ## exp and obs (2) + if (!is.null(exp) & !is.null(obs)) { + 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 the same length of ", + "all dimensions except 'memb_dim'.")) + } + } + ## ftime_avg + if (!is.vector(ftime_avg) | !is.integer(ftime_avg)) { + stop("Parameter 'ftime_avg' must be an integer vector.") + } + if (!is.null(exp)) { + if (max(ftime_avg) > dim(exp)[ftime_dim] | min(ftime_avg) < 1) { + stop("Parameter 'ftime_avg' must be within the range of ftime_dim length.") + } + } else { + if (max(ftime_avg) > dim(obs)[ftime_dim] | min(ftime_avg) < 1) { + stop("Parameter 'ftime_avg' must be within the range of ftime_dim length.") + } + } + ## sdate >= 2 + if (!is.null(exp)) { + if (dim(exp)[time_dim] < 2) { + stop("The length of time_dim must be at least 2.") + } + } else { + if (dim(obs)[time_dim] < 2) { + stop("The length of time_dim must be at least 2.") + } + } + ## lat and lon + if (!is.null(exp)) { + if (!is.numeric(lat) | length(lat) != dim(exp)[space_dim[1]]) { + stop(paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'exp' and 'obs'.")) + } + if (!is.numeric(lon) | length(lon) != dim(exp)[space_dim[2]]) { + stop(paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'exp' and 'obs'.")) + } + } else { + if (!is.numeric(lat) | length(lat) != dim(obs)[space_dim[1]]) { + stop(paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'exp' and 'obs'.")) + } + if (!is.numeric(lon) | length(lon) != dim(obs)[space_dim[2]]) { + stop(paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'exp' and 'obs'.")) + } + } + stop_needed <- FALSE + if (tail(lat, 1) < 70 | tail(lat, 1) > 90 | + head(lat, 1) > 30 | head(lat, 1) < 10) { + stop_needed <- TRUE + } + #NOTE: different from s2dverification + # lon is not used in the calculation actually. EOF only uses lat to do the + # weight. So we just need to ensure the data is in this region, regardless + # the order. + if (any(lon < 0)) { #[-180, 180] + if (!(min(lon) > -90 & min(lon) < -70 & max(lon) < 50 & max(lon) > 30)) { + stop_needed <- TRUE + } + } else { #[0, 360] + if (any(lon >= 50 & lon <= 270)) { + stop_needed <- TRUE + } else { + lon_E <- lon[which(lon < 50)] + lon_W <- lon[-which(lon < 50)] + if (max(lon_E) < 30 | min(lon_W) > 290) { + stop_needed <- TRUE + } + } + } + if (stop_needed) { + stop(paste0("The typical domain used to compute the NAO is 20N-80N, ", + "80W-40E. 'lat' or 'lon' is out of range.")) + } + ## obsproj + if (!is.logical(obsproj) | length(obsproj) > 1) { + stop("Parameter 'obsproj' must be either TRUE or FALSE.") + } + if (obsproj) { + if (is.null(obs)) { + stop("Parameter 'obsproj' set to TRUE but no 'obs' provided.") + } + if (is.null(exp)) { + .warning("parameter 'obsproj' set to TRUE but no 'exp' provided.") + } + } + ## 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.") + } + } + + #-------- Average ftime ----------- + if (!is.null(exp)) { + exp_sub <- ClimProjDiags::Subset(exp, ftime_dim, ftime_avg, drop = FALSE) + exp <- MeanDims(exp_sub, ftime_dim, na.rm = TRUE) + ## Cross-validated PCs. Fabian. This should be extended to + ## nmod and nlt by simple loops. Virginie + } + + if (!is.null(obs)) { + obs_sub <- ClimProjDiags::Subset(obs, ftime_dim, ftime_avg, drop = FALSE) + obs <- MeanDims(obs_sub, ftime_dim, na.rm = TRUE) + } + + if (!is.null(exp) & !is.null(obs)) { + res <- Apply(list(exp, obs), + target_dims = list(exp = c(memb_dim, time_dim, space_dim), + obs = c(memb_dim, time_dim, space_dim)), + fun = .NAO, + obsproj = obsproj, lat = lat, lon = lon, + ncores = ncores) + } else if (!is.null(exp)) { + res <- Apply(list(exp = exp), + target_dims = list(exp = c(memb_dim, time_dim, space_dim)), + fun = .NAO, + obsproj = obsproj, lat = lat, lon = lon, obs = NULL, + ncores = ncores) + } else if (!is.null(obs)) { + res <- Apply(list(obs = obs), + target_dims = list(obs = c(memb_dim, time_dim, space_dim)), + fun = .NAO, + obsproj = obsproj, lat = lat, lon = lon, exp = NULL, + ncores = ncores) + } + return(res) +} + +.NAO <- function(exp = NULL, obs = NULL, lat, lon, + obsproj = TRUE, ncores = NULL) { + # exp: [memb_exp, sdate, lat, lon] + # obs: [memb_obs, sdate, lat, lon] + if (!is.null(exp)) { + ntime <- dim(exp)[2] + nlat <- dim(exp)[3] + nlon <- dim(exp)[4] + nmemb_exp <- dim(exp)[1] + nmemb_obs <- dim(obs)[1] + } else { + ntime <- dim(obs)[2] + nlat <- dim(obs)[3] + nlon <- dim(obs)[4] + nmemb_obs <- dim(obs)[1] + } + + if (!is.null(obs)) NAOO.ver <- array(NA, dim = c(ntime, nmemb_obs)) + if (!is.null(exp)) NAOF.ver <- array(NA, dim = c(ntime, nmemb_exp)) + + for (tt in 1:ntime) { #sdate + + if (!is.null(obs)) { + ## Observed EOF excluding one forecast start year. + obs_sub <- ClimProjDiags::Subset(obs, 2, c(1:ntime)[-tt], drop = FALSE) + obs_EOF <- EOF(obs_sub, lat = lat, lon = lon, time_dim = names(ntime), + space_dim = c(names(nlat), names(nlon)), neofs = 1) + + ## Correct polarity of pattern. + #NOTE: different from s2dverification + # dim(obs_EOF$EOFs): [mode, lat, lon, member] + for (imemb in 1:nmemb_obs) { + if (0 < mean(obs_EOF$EOFs[1, which.min(abs(lat - 65)), , ], na.rm = T)) { + obs_EOF$EOFs[1, , , imemb] <- obs_EOF$EOFs[1, , , imemb] * (-1) + } + } +# obs_EOF$PCs <- obs_EOF$PCs * sign # not used + + ## Project observed anomalies. + PF <- ProjectField(obs, eof = obs_EOF, time_dim = names(ntime), + space_dim = c(names(nlat), names(nlon)), mode = 1) + NAOO.ver[tt, ] <- PF[tt, ] + ## Keep PCs of excluded forecast start year. Fabian. + } + + if (!is.null(exp)) { + if (!obsproj) { + exp_sub <- ClimProjDiags::Subset(exp, 2, c(1:ntime)[-tt], drop = FALSE) + #NOTE: different from s2dverification. Here, 'member' is considered. + exp_EOF <- EOF(exp_sub, lat = lat, lon = lon, time_dim = names(ntime), + space_dim = c(names(nlat), names(nlon)), neofs = 1) + + ## Correct polarity of pattern. + #NOTE: different from s2dverification + for (imemb in 1:nmemb_exp) { + if (0 < mean(exp_EOF$EOFs[1, which.min(abs(lat - 65)), , imemb], na.rm = T)) { + exp_EOF$EOFs[1, , , imemb] <- exp_EOF$EOFs[1, , , imemb] * (-1) + } + } +# exp_EOF$PCs <- exp_EOF$PCs * sign # not used + + ### Lines below could be simplified further by computing + ### ProjectField() only on the year of interest... (though this is + ### not vital). Lauriane + PF <- ProjectField(exp, eof = exp_EOF, time_dim = names(ntime), + space_dim = c(names(nlat), names(nlon)), mode = 1) + NAOF.ver[tt, ] <- PF[tt, ] + + } else { + ## Project forecast anomalies on obs EOF + #NOTE: Because obs and exp have different nmemb, do ensemble mean to + # obs_EOF$EOFs first, then expand the memb dim to be the same as exp. + obs_EOF$EOFs <- apply(obs_EOF$EOFs, c(1, 2, 3), mean, na.rm = T) + obs_EOF$EOFs <- array(obs_EOF$EOFs, dim = c(dim(obs_EOF$EOFs), as.numeric(nmemb_exp))) + names(dim(obs_EOF$EOFs))[4] <- names(nmemb_obs) + PF <- ProjectField(exp, obs_EOF, mode = 1) + NAOF.ver[tt, ] <- PF[tt, ] + } + } + } + #NOTE: EOFs_obs is not returned because it's only the result of the last sdate + # (It is returned in s2dverification.) + if (!is.null(exp) & !is.null(obs)) { + return(list(exp = NAOF.ver, obs = NAOO.ver)) #, EOFs_obs = obs_EOF)) + } else if (!is.null(exp)) { + return(list(exp = NAOF.ver)) + } else if (!is.null(obs)) { + return(list(obs = NAOO.ver)) + } +} diff --git a/R/PlotBoxWhisker.R b/R/PlotBoxWhisker.R new file mode 100644 index 0000000..2ddcec0 --- /dev/null +++ b/R/PlotBoxWhisker.R @@ -0,0 +1,242 @@ +#'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 <- s2dv:::.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) +#'sampleData$lat[] <- c(20, 80) +#' } +#'# Now ready to compute the EOFs and project on, for example, the first +#'# variability mode. +#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'ano_exp <- array(ano$exp, dim = dim(ano$exp)[-2]) +#'ano_obs <- array(ano$obs, dim = dim(ano$obs)[-2]) +#'nao <- NAO(ano_exp, ano_obs, sampleData$lat, sampleData$lon) +#'# Finally plot the nao index +#' \dontrun{ +#'nao$exp <- Reorder(nao$exp, c(2, 1)) +#'nao$obs <- Reorder(nao$obs, c(2, 1)) +#'PlotBoxWhisker(nao$exp, 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 = 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("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/man/NAO.Rd b/man/NAO.Rd new file mode 100644 index 0000000..c61a5ac --- /dev/null +++ b/man/NAO.Rd @@ -0,0 +1,124 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/NAO.R +\name{NAO} +\alias{NAO} +\title{Compute the North Atlantic Oscillation (NAO) Index} +\usage{ +NAO( + exp = NULL, + obs = NULL, + lat, + lon, + time_dim = "sdate", + memb_dim = "member", + space_dim = c("lat", "lon"), + ftime_dim = "ftime", + ftime_avg = 2:4, + obsproj = TRUE, + ncores = NULL +) +} +\arguments{ +\item{exp}{A named numeric array of North Atlantic SLP (20N-80N, 80W-40E) +forecast anomalies from \code{Ano()} or \code{Ano_CrossValid()} with +dimensions 'time_dim', 'memb_dim', 'ftime_dim', and 'space_dim' at least. +If only NAO of observational data needs to be computed, this parameter can +be left to NULL. The default value is NULL.} + +\item{obs}{A named numeric array of North Atlantic SLP (20N-80N, 80W-40E) +observed anomalies from \code{Ano()} or \code{Ano_CrossValid()} with +dimensions 'time_dim', 'memb_dim', 'ftime_dim', and 'space_dim' at least. +If only NAO of experimental data needs to be computed, this parameter can +be left to NULL. The default value is NULL.} + +\item{lat}{A vector of the latitudes of 'exp' and 'obs'.} + +\item{lon}{A vector of the longitudes of 'exp' and 'obs'.} + +\item{time_dim}{A character string indicating the name of the time dimension +of 'exp' and 'obs'. The default value is 'sdate'.} + +\item{memb_dim}{A character string indicating the name of the member +dimension of 'exp' and 'obs'. The default value is 'member'.} + +\item{space_dim}{A vector of two character strings. The first is the dimension +name of latitude of 'ano' and the second is the dimension name of longitude +of 'ano'. The default value is c('lat', 'lon').} + +\item{ftime_dim}{A character string indicating the name of the forecast time +dimension of 'exp' and 'obs'. The default value is 'ftime'.} + +\item{ftime_avg}{A numeric vector of the forecast time steps to average +across the target period. The default value is 2:4, i.e., from 2nd to 4th +forecast time steps.} + +\item{obsproj}{A logical value indicating whether to compute the NAO index by +projecting the forecast anomalies onto the leading EOF of observational +reference (TRUE) or compute the NAO by first computing the leading +EOF of the forecast anomalies (in cross-validation mode, i.e. leaving the +year you are evaluating out), and then projecting forecast anomalies onto +this EOF (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 which contains: +\item{exp}{ + A numeric array of forecast NAO index in verification format with the same + dimensions as 'exp' except space_dim and ftime_dim. + } +\item{obs}{ + A numeric array of observed NAO index in verification format with the same + dimensions as 'obs' except space_dim and ftime_dim. +} +} +\description{ +Compute the North Atlantic Oscillation (NAO) index based on the leading EOF +of the sea level pressure (SLP) anomalies over the north Atlantic region +(20N-80N, 80W-40E). The PCs are obtained by projecting the forecast and +observed anomalies onto the observed EOF pattern (Pobs) or the forecast +anomalies onto the EOF pattern of the other years of the forecast (Pmod). +By default (ftime_avg = 2:4) NAO() computes the NAO index for 1-month +lead seasonal forecasts that can be plotted with PlotBoxWhisker(). It returns +cross-validated PCs of the NAO index for forecast (exp) and observations +(obs) based on the leading EOF pattern. +} +\examples{ + \dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, 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 +# the NAO region directly. +sampleData$lon[] <- c(40, 280, 340) +sampleData$lat[] <- c(20, 80) + } + +# Now ready to compute the EOFs and project on, for example, the first +# variability mode. +ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +# Note that computing the NAO over the region for which there is available +# example data is not the full NAO area: NAO() will raise a warning. +nao <- NAO(ano$exp, ano$obs, sampleData$lat, sampleData$lon) +# Finally plot the NAO index + \dontrun{ +nao$exp <- Reorder(nao$exp, c(2, 1)) +nao$obs <- Reorder(nao$obs, c(2, 1)) +PlotBoxWhisker(nao$exp, nao$obs, "NAO index, DJF", "NAO index (PC1) TOS", + monini = 12, yearini = 1985, freq = 1, "Exp. A", "Obs. X") + } + +} +\references{ +Doblas-Reyes, F.J., Pavan, V. and Stephenson, D. (2003). The skill of + multi-model seasonal forecasts of the wintertime North Atlantic + Oscillation. Climate Dynamics, 21, 501-514. + DOI: 10.1007/s00382-003-0350-4 +} diff --git a/man/PlotBoxWhisker.Rd b/man/PlotBoxWhisker.Rd new file mode 100644 index 0000000..9c5a3f4 --- /dev/null +++ b/man/PlotBoxWhisker.Rd @@ -0,0 +1,146 @@ +% 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 = NULL, + 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 <- s2dv:::.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) +sampleData$lat[] <- c(20, 80) + } +# Now ready to compute the EOFs and project on, for example, the first +# variability mode. +ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +ano_exp <- array(ano$exp, dim = dim(ano$exp)[-2]) +ano_obs <- array(ano$obs, dim = dim(ano$obs)[-2]) +nao <- NAO(ano_exp, ano_obs, sampleData$lat, sampleData$lon) +# Finally plot the nao index + \dontrun{ +nao$exp <- Reorder(nao$exp, c(2, 1)) +nao$obs <- Reorder(nao$obs, c(2, 1)) +PlotBoxWhisker(nao$exp, nao$obs, "NAO index, DJF", "NAO index (PC1) TOS", + monini = 12, yearini = 1985, freq = 1, "Exp. A", "Obs. X") + } + +} +\seealso{ +EOF, ProjectField, NAO +} +\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 +} +\keyword{datagen} diff --git a/tests/testthat/test-NAO.R b/tests/testthat/test-NAO.R new file mode 100644 index 0000000..d0acbd5 --- /dev/null +++ b/tests/testthat/test-NAO.R @@ -0,0 +1,222 @@ +context("s2dv::NAO tests") + +############################################## + # dat1 + set.seed(1) + exp1 <- array(rnorm(144), dim = c(member = 2, sdate = 3, ftime = 4, lat = 2, lon = 3)) + set.seed(2) + obs1 <- array(rnorm(72), dim = c(member = 1, sdate = 3, ftime = 4, lat = 2, lon = 3)) + lat1 <- c(20, 80) + lon1 <- c(40, 280, 350) + + # dat2 + set.seed(1) + exp2 <- array(rnorm(144), dim = c(sdate = 3, ftime = 4, member = 2, lat = 2, lon = 3)) + set.seed(2) + obs2 <- array(rnorm(144), dim = c(member = 2, sdate = 3, ftime = 4, lat = 2, lon = 3)) + lat2 <- c(20, 80) + lon2 <- c(-80, 0, 40) + +############################################## +test_that("1. Input checks", { + + # exp and obs (1) + expect_error( + NAO(c(), c()), + "Parameter 'exp' and 'obs' cannot both be NULL." + ) + expect_error( + NAO(exp = c(NA, NA)), + "Parameter 'exp' must be a numeric array." + ) + expect_error( + NAO(exp = c(1:10)), + paste0("Parameter 'exp' and must have at least dimensions ", + "time_dim, memb_dim, space_dim, and ftime_dim.") + ) + expect_error( + NAO(array(1:10, dim = c(2, 5))), + "Parameter 'exp' must have dimension names." + ) + expect_error( + NAO(exp = exp1, obs = c(NA, NA)), + "Parameter 'obs' must be a numeric array." + ) + expect_error( + NAO(exp = exp1, obs = c(1:10)), + paste0("Parameter 'obs' and must have at least dimensions ", + "time_dim, memb_dim, space_dim, and ftime_dim.") + ) + expect_error( + NAO(exp = exp1, obs = array(1:10, dim = c(2, 5))), + "Parameter 'obs' must have dimension names." + ) + # time_dim + expect_error( + NAO(exp1, obs1, time_dim = 2), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + NAO(exp1, obs1, time_dim = 'a'), + "Parameter 'time_dim' is not found in 'exp' or 'obs' dimension." + ) + # memb_dim + expect_error( + NAO(exp1, obs1, memb_dim = 2), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + NAO(exp1, obs1, memb_dim = 'a'), + "Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension." + ) + # space_dim + expect_error( + NAO(exp1, obs1, space_dim = 'lat'), + "Parameter 'space_dim' must be a character vector of 2." + ) + expect_error( + NAO(exp1, obs1, space_dim = c('latitude', 'longitude')), + "Parameter 'space_dim' is not found in 'exp' or 'obs' dimension." + ) + # ftime_dim + expect_error( + NAO(exp1, obs1, ftime_dim = 2), + "Parameter 'ftime_dim' must be a character string." + ) + expect_error( + NAO(exp1, obs1, ftime_dim = 'a'), + "Parameter 'ftime_dim' is not found in 'exp' or 'obs' dimension." + ) + # exp and obs (2) + expect_error( + NAO(exp1, array(rnorm(10), dim = c(member = 10, sdate = 3, ftime = 4, lat = 2, lon = 2))), + paste0("Parameter 'exp' and 'obs' must have the same length of ", + "all dimensions except 'memb_dim'.") + ) + # ftime_avg + expect_error( + NAO(exp1, obs1, ftime_avg = T), + "Parameter 'ftime_avg' must be an integer vector." + ) + expect_error( + NAO(exp1, obs1, ftime_avg = 1:10), +"Parameter 'ftime_avg' must be within the range of ftime_dim length." + ) + # sdate >= 2 + expect_error( + NAO(exp = array(rnorm(10), dim = c(member = 10, sdate = 1, ftime = 4, lat = 2, lon = 2)), + obs = array(rnorm(10), dim = c(member = 10, sdate = 1, ftime = 4, lat = 2, lon = 2))), + "The length of time_dim must be at least 2." + ) + # lat and lon + expect_error( + NAO(exp1, obs1, lat = 1:10), + paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'exp' and 'obs'.") + ) + expect_error( + NAO(exp1, obs1, lat = lat1, lon = c('a', 'b')), + paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'exp' and 'obs'.") + ) + expect_error( + NAO(exp1, obs1, lat = c(1, 2), lon = lon1), + paste0("The typical domain used to compute the NAO is 20N-80N, ", + "80W-40E. 'lat' or 'lon' is out of range.") + ) + expect_error( + NAO(exp1, obs1, lat = c(-10, -5), lon = lon1), + paste0("The typical domain used to compute the NAO is 20N-80N, ", + "80W-40E. 'lat' or 'lon' is out of range.") + ) + expect_error( + NAO(exp1, obs1, lat = lat1, lon = c(40, 50, 60)), + paste0("The typical domain used to compute the NAO is 20N-80N, ", + "80W-40E. 'lat' or 'lon' is out of range.") + ) + # obsproj + expect_error( + NAO(exp1, obs1, lat = lat1, lon = lon1, obsproj = 1), + "Parameter 'obsproj' must be either TRUE or FALSE." + ) + expect_error( + NAO(exp = exp1, lat = lat1, lon = lon1), + "Parameter 'obsproj' set to TRUE but no 'obs' provided." + ) + # ncores + expect_error( + NAO(exp1, obs1, lat1, lon1, ncore = 3.5), + "Parameter 'ncores' must be a positive integer." + ) + +}) +############################################## +test_that("2. dat1", { + + expect_equal( + names(NAO(exp1, obs1, lat = lat1, lon = lon1)), + c("exp", "obs") + ) + expect_equal( + dim(NAO(exp1, obs1, lat = lat1, lon = lon1)$exp), + c(sdate = 3, member = 2) + ) + expect_equal( + dim(NAO(exp1, obs1, lat = lat1, lon = lon1)$obs), + c(sdate = 3, member = 1) + ) + expect_equal( + NAO(exp1, obs1, lat = lat1, lon = lon1)$exp[1:5], + c(-0.1995564, -0.2996030, 0.7340010, -0.2747980, -0.3606155), + tolerance = 0.0001 + ) + expect_equal( + NAO(exp1, obs1, lat = lat1, lon = lon1)$obs[1:3], + c(-0.1139683, 0.1056687, 0.1889449), + tolerance = 0.0001 + ) + expect_equal( + mean(NAO(exp1, obs1, lat = lat1, lon = lon1, obsproj = FALSE)$exp), + -0.1362706, + tolerance = 0.0001 + ) + expect_equal( + names(NAO(exp = exp1, lat = lat1, lon = lon1, obsproj = FALSE)), + c("exp") + ) + suppressWarnings( + expect_equal( + names(NAO(obs = obs1, lat = lat1, lon = lon1)), + c("obs") + ) + ) + +}) +############################################## +test_that("3. dat2", { + expect_equal( + dim(NAO(exp2, obs2, lat = lat2, lon = lon2)$exp), + c(sdate = 3, member = 2) + ) + expect_equal( + dim(NAO(exp2, obs2, lat = lat2, lon = lon2)$obs), + c(sdate = 3, member = 2) + ) + expect_equal( + mean(NAO(exp2, obs2, lat = lat2, lon = lon2)$exp), + -0.01566486, + tolerance = 0.00001 + ) + expect_equal( + NAO(exp2, obs2, lat = lat2, lon = lon2)$exp[2:4], + c(0.16231137, -0.10984650, -0.01871716), + tolerance = 0.00001 + ) + expect_equal( + NAO(exp2, obs2, lat = lat2, lon = lon2, ftime_avg = 1:3)$exp[2:4], + c(-0.30102528, -0.06366782, 0.01639220), + tolerance = 0.00001 + ) +}) + +############################################## -- GitLab From 34596b670fb6ee7140f607cb37c2c9bbed32afc3 Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 5 Feb 2021 09:25:43 +0100 Subject: [PATCH 08/28] Update documentation with devtools_2.2.1 --- DESCRIPTION | 2 +- NAMESPACE | 2 + R/Ano_CrossValid.R | 16 +++--- R/EOF.R | 2 +- R/ProjectField.R | 8 +-- man/AMV.Rd | 21 +++++-- man/AnimateMap.Rd | 33 ++++++++--- man/Ano.Rd | 1 - man/Ano_CrossValid.Rd | 18 ++++-- man/Clim.Rd | 16 ++++-- man/ColorBar.Rd | 32 ++++++++--- man/Composite.Rd | 14 ++++- man/ConfigApplyMatchingEntries.Rd | 11 +++- man/ConfigEditDefinition.Rd | 1 - man/ConfigEditEntry.Rd | 45 +++++++++++---- man/ConfigFileOpen.Rd | 3 +- man/ConfigShowSimilarEntries.Rd | 17 ++++-- man/ConfigShowTable.Rd | 3 +- man/Corr.Rd | 17 ++++-- man/EOF.Rd | 15 +++-- man/Eno.Rd | 1 - man/GMST.Rd | 24 ++++++-- man/GSAT.Rd | 21 +++++-- man/InsertDim.Rd | 1 - man/LeapYear.Rd | 1 - man/Load.Rd | 40 +++++++++---- man/MeanDims.Rd | 1 - man/Persistence.Rd | 17 ++++-- man/PlotAno.Rd | 31 +++++++--- man/PlotClim.Rd | 26 +++++++-- man/PlotEquiMap.Rd | 86 +++++++++++++++++++++------- man/PlotLayout.Rd | 73 ++++++++++++++++------- man/PlotMatrix.Rd | 29 +++++++--- man/PlotSection.Rd | 25 ++++++-- man/PlotStereoMap.Rd | 61 +++++++++++++++----- man/ProjectField.Rd | 23 +++++--- man/RMS.Rd | 14 ++++- man/RMSSS.Rd | 11 +++- man/RandomWalkTest.Rd | 1 - man/Regression.Rd | 14 ++++- man/Reorder.Rd | 1 - man/SPOD.Rd | 21 +++++-- man/Season.Rd | 13 ++++- man/Smoothing.Rd | 1 - man/TPI.Rd | 21 +++++-- man/ToyModel.Rd | 15 ++++- man/Trend.Rd | 13 ++++- man/clim.palette.Rd | 3 +- man/s2dv-package.Rd | 47 +++++++++++---- man/sampleDepthData.Rd | 1 - man/sampleMap.Rd | 1 - man/sampleTimeSeries.Rd | 1 - tests/testthat/test-Ano_CrossValid.R | 18 +++--- 53 files changed, 681 insertions(+), 252 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 126179a..30fd237 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,4 +45,4 @@ BugReports: https://earth.bsc.es/gitlab/es/s2dv/-/issues LazyData: true SystemRequirements: cdo Encoding: UTF-8 -RoxygenNote: 5.0.0 +RoxygenNote: 7.0.1 diff --git a/NAMESPACE b/NAMESPACE index 9726809..5264aec 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,8 +28,10 @@ export(InsertDim) export(LeapYear) export(Load) export(MeanDims) +export(NAO) export(Persistence) export(PlotAno) +export(PlotBoxWhisker) export(PlotClim) export(PlotEquiMap) export(PlotLayout) diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index cdbf233..e4a8b77 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -26,11 +26,11 @@ #' #'@return #'A list of 2: -#'\item{$ano_exp}{ +#'\item{$exp}{ #' A numeric array with the same dimensions as 'exp'. The dimension order may #' change. #'} -#'\item{$ano_obs}{ +#'\item{$obs}{ #' A numeric array with the same dimensions as 'obs'.The dimension order may #' change. #'} @@ -40,7 +40,7 @@ #'example(Load) #'anomalies <- Ano_CrossValid(sampleData$mod, sampleData$obs) #'\dontrun{ -#'PlotAno(anomalies$ano_exp, anomalies$ano_obs, startDates, +#'PlotAno(anomalies$exp, anomalies$obs, startDates, #' toptitle = paste('anomalies'), ytitle = c('K', 'K', 'K'), #' legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano_crossvalid.eps') #'} @@ -115,8 +115,8 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', 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'.")) + stop(paste0("Parameter 'exp' and 'obs' must have the same length of ", + "all dimensions except 'dat_dim'.")) } ############################### @@ -167,8 +167,8 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', for (tt in 1:dim(exp)[1]) { #[sdate] # calculate clim - exp_sub <- Subset(exp_for_clim, 1, c(1:dim(exp)[1])[-tt]) - obs_sub <- Subset(obs_for_clim, 1, c(1:dim(obs)[1])[-tt]) + exp_sub <- ClimProjDiags::Subset(exp_for_clim, 1, c(1:dim(exp)[1])[-tt]) + obs_sub <- ClimProjDiags::Subset(obs_for_clim, 1, c(1:dim(obs)[1])[-tt]) clim_exp <- apply(exp_sub, c(1:length(dim(exp)))[-1], mean, na.rm = TRUE) # average out time_dim -> [dat, memb] clim_obs <- apply(obs_sub, c(1:length(dim(obs)))[-1], mean, na.rm = TRUE) @@ -217,5 +217,5 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', ano_obs <- array(unlist(ano_obs_list), dim = c(dim(obs)[-1], dim(obs)[1])) ano_obs <- Reorder(ano_obs, c(length(dim(obs)), 1:(length(dim(obs)) - 1))) - return(list(ano_exp = ano_exp, ano_obs = ano_obs)) + return(list(exp = ano_exp, obs = ano_obs)) } diff --git a/R/EOF.R b/R/EOF.R index cf04c42..c595d4b 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -66,7 +66,7 @@ #' lonmin = -12, lonmax = 40) #'} #'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -#'tmp <- MeanDims(ano$ano_exp, c('dataset', 'member')) +#'tmp <- MeanDims(ano$exp, c('dataset', 'member')) #'ano <- tmp[, 1, ,] #'names(dim(ano)) <- names(dim(tmp))[-2] #'eof <- EOF(ano, sampleData$lat, sampleData$lon) diff --git a/R/ProjectField.R b/R/ProjectField.R index 16ab178..03ad210 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -36,10 +36,10 @@ #' lonmin = -12, lonmax = 40) #'} #'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -#'eof_exp <- EOF(ano$ano_exp, sampleData$lat, sampleData$lon) -#'eof_obs <- EOF(ano$ano_obs, sampleData$lat, sampleData$lon) -#'mode1_exp <- ProjectField(ano$ano_exp, eof_exp) -#'mode1_obs <- ProjectField(ano$ano_obs, eof_obs) +#'eof_exp <- EOF(ano$exp, sampleData$lat, sampleData$lon) +#'eof_obs <- EOF(ano$obs, sampleData$lat, sampleData$lon) +#'mode1_exp <- ProjectField(ano$exp, eof_exp) +#'mode1_obs <- ProjectField(ano$obs, eof_obs) #' #'\dontrun{ #' # Plot the forecast and the observation of the first mode for the last year diff --git a/man/AMV.Rd b/man/AMV.Rd index 5aa6d30..881e136 100644 --- a/man/AMV.Rd +++ b/man/AMV.Rd @@ -4,10 +4,22 @@ \alias{AMV} \title{Compute the Atlantic Multidecadal Variability (AMV) index} \usage{ -AMV(data, data_lats, data_lons, type, lat_dim = "lat", lon_dim = "lon", - mask = NULL, monini = 11, fmonth_dim = "fmonth", sdate_dim = "sdate", - indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member") +AMV( + data, + data_lats, + data_lons, + type, + lat_dim = "lat", + lon_dim = "lon", + mask = NULL, + monini = 11, + fmonth_dim = "fmonth", + sdate_dim = "sdate", + indices_for_clim = NULL, + year_dim = "year", + month_dim = "month", + member_dim = "member" +) } \arguments{ \item{data}{A numerical array to be used for the index computation with the @@ -106,4 +118,3 @@ lon <- seq(0, 360, 10) index_dcpp <- AMV(data = dcpp, data_lats = lat, data_lons = lon, type = 'dcpp', monini = 1) } - diff --git a/man/AnimateMap.Rd b/man/AnimateMap.Rd index d2003ee..2ec930d 100644 --- a/man/AnimateMap.Rd +++ b/man/AnimateMap.Rd @@ -4,13 +4,33 @@ \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, +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"), ...) + "output3_animvsltime.gif"), + ... +) } \arguments{ \item{var}{Matrix of dimensions (nltime, nlat, nlon) or @@ -162,4 +182,3 @@ AnimateMap(clim$clim_exp, sampleData$lon, sampleData$lat, # More examples in s2dverification but are deleted for now } - diff --git a/man/Ano.Rd b/man/Ano.Rd index 2dd4dea..8e423af 100644 --- a/man/Ano.Rd +++ b/man/Ano.Rd @@ -41,4 +41,3 @@ PlotAno(ano_exp, ano_obs, startDates, legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano.png') } } - diff --git a/man/Ano_CrossValid.Rd b/man/Ano_CrossValid.Rd index fa56a75..bef1524 100644 --- a/man/Ano_CrossValid.Rd +++ b/man/Ano_CrossValid.Rd @@ -4,8 +4,15 @@ \alias{Ano_CrossValid} \title{Compute anomalies in cross-validation mode} \usage{ -Ano_CrossValid(exp, obs, time_dim = "sdate", dat_dim = c("dataset", - "member"), memb_dim = "member", memb = TRUE, ncores = NULL) +Ano_CrossValid( + exp, + obs, + time_dim = "sdate", + dat_dim = c("dataset", "member"), + memb_dim = "member", + memb = TRUE, + ncores = NULL +) } \arguments{ \item{exp}{A named numeric array of experimental data, with at least @@ -36,11 +43,11 @@ computation. The default value is NULL.} } \value{ A list of 2: -\item{$ano_exp}{ +\item{$exp}{ A numeric array with the same dimensions as 'exp'. The dimension order may change. } -\item{$ano_obs}{ +\item{$obs}{ A numeric array with the same dimensions as 'obs'.The dimension order may change. } @@ -55,9 +62,8 @@ technique and a per-pair method. example(Load) anomalies <- Ano_CrossValid(sampleData$mod, sampleData$obs) \dontrun{ -PlotAno(anomalies$ano_exp, anomalies$ano_obs, startDates, +PlotAno(anomalies$exp, anomalies$obs, startDates, toptitle = paste('anomalies'), ytitle = c('K', 'K', 'K'), legends = 'ERSST', biglab = FALSE, fileout = 'tos_ano_crossvalid.eps') } } - diff --git a/man/Clim.Rd b/man/Clim.Rd index a997a7f..78559bd 100644 --- a/man/Clim.Rd +++ b/man/Clim.Rd @@ -4,9 +4,18 @@ \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 = TRUE, - memb_dim = "member", na.rm = TRUE, ncores = NULL) +Clim( + exp, + obs, + time_dim = "sdate", + dat_dim = c("dataset", "member"), + method = "clim", + ftime_dim = "ftime", + memb = TRUE, + memb_dim = "member", + na.rm = TRUE, + ncores = NULL +) } \arguments{ \item{exp}{A named numeric array of experimental data, with at least two @@ -82,4 +91,3 @@ PlotClim(clim$clim_exp, clim$clim_obs, listobs = c('ERSST'), biglab = FALSE, fileout = 'tos_clim.eps') } } - diff --git a/man/ColorBar.Rd b/man/ColorBar.Rd index 1287b70..6d62f15 100644 --- a/man/ColorBar.Rd +++ b/man/ColorBar.Rd @@ -4,13 +4,30 @@ \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, ...) +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: @@ -175,4 +192,3 @@ cols <- c("dodgerblue4", "dodgerblue1", "forestgreen", "yellowgreen", "white", lims <- seq(-1, 1, 0.2) ColorBar(lims, cols) } - diff --git a/man/Composite.Rd b/man/Composite.Rd index 64d5bfc..cc21d38 100644 --- a/man/Composite.Rd +++ b/man/Composite.Rd @@ -4,8 +4,17 @@ \alias{Composite} \title{Compute composites} \usage{ -Composite(data, occ, time_dim = "time", space_dim = c("lon", "lat"), - lag = 0, eno = FALSE, K = NULL, fileout = NULL, ncores = NULL) +Composite( + data, + occ, + time_dim = "time", + space_dim = c("lon", "lat"), + lag = 0, + eno = FALSE, + K = NULL, + fileout = NULL, + ncores = NULL +) } \arguments{ \item{data}{A numeric array containing two spatial and one temporal @@ -101,4 +110,3 @@ occ <- c(1, 1, 2, 2, 3, 3) res <- Composite(data, occ, time_dim = 'case', K = 4) } - diff --git a/man/ConfigApplyMatchingEntries.Rd b/man/ConfigApplyMatchingEntries.Rd index 5f0efb1..ee4cb5a 100644 --- a/man/ConfigApplyMatchingEntries.Rd +++ b/man/ConfigApplyMatchingEntries.Rd @@ -4,8 +4,14 @@ \alias{ConfigApplyMatchingEntries} \title{Apply Matching Entries To Dataset Name And Variable Name To Find Related Info} \usage{ -ConfigApplyMatchingEntries(configuration, var, exp = NULL, obs = NULL, - show_entries = FALSE, show_result = TRUE) +ConfigApplyMatchingEntries( + configuration, + var, + exp = NULL, + obs = NULL, + show_entries = FALSE, + show_result = TRUE +) } \arguments{ \item{configuration}{Configuration object obtained from ConfigFileOpen() @@ -68,4 +74,3 @@ ConfigApplyMatchingEntries, ConfigEditDefinition, ConfigEditEntry, ConfigFileOpen, ConfigShowSimilarEntries, ConfigShowTable } - diff --git a/man/ConfigEditDefinition.Rd b/man/ConfigEditDefinition.Rd index 8e1e968..223e95a 100644 --- a/man/ConfigEditDefinition.Rd +++ b/man/ConfigEditDefinition.Rd @@ -57,4 +57,3 @@ match_info <- ConfigApplyMatchingEntries(configuration, 'tas', [ConfigEditEntry()], [ConfigFileOpen()], [ConfigShowSimilarEntries()], [ConfigShowTable()]. } - diff --git a/man/ConfigEditEntry.Rd b/man/ConfigEditEntry.Rd index 9abf3e5..e597709 100644 --- a/man/ConfigEditEntry.Rd +++ b/man/ConfigEditEntry.Rd @@ -1,22 +1,46 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ConfigEditEntry.R \name{ConfigEditEntry} -\alias{ConfigAddEntry} \alias{ConfigEditEntry} +\alias{ConfigAddEntry} \alias{ConfigRemoveEntry} \title{Add, Remove Or Edit Entries In The Configuration} \usage{ -ConfigEditEntry(configuration, dataset_type, position, dataset_name = NULL, - var_name = NULL, main_path = NULL, file_path = NULL, - nc_var_name = NULL, suffix = NULL, varmin = NULL, varmax = NULL) +ConfigEditEntry( + configuration, + dataset_type, + position, + dataset_name = NULL, + var_name = NULL, + main_path = NULL, + file_path = NULL, + nc_var_name = NULL, + suffix = NULL, + varmin = NULL, + varmax = NULL +) -ConfigAddEntry(configuration, dataset_type, position = "last", - dataset_name = ".*", var_name = ".*", main_path = "*", - file_path = "*", nc_var_name = "*", suffix = "*", varmin = "*", - varmax = "*") +ConfigAddEntry( + configuration, + dataset_type, + position = "last", + dataset_name = ".*", + var_name = ".*", + main_path = "*", + file_path = "*", + nc_var_name = "*", + suffix = "*", + varmin = "*", + varmax = "*" +) -ConfigRemoveEntry(configuration, dataset_type, dataset_name = NULL, - var_name = NULL, position = NULL) +ConfigRemoveEntry( + configuration, + dataset_type, + dataset_name = NULL, + var_name = NULL, + position = NULL +) } \arguments{ \item{configuration}{Configuration object obtained via ConfigFileOpen() @@ -99,4 +123,3 @@ ConfigFileSave(configuration, config_file, confirm = FALSE) ConfigApplyMatchingEntries, ConfigEditDefinition, ConfigEditEntry, ConfigFileOpen, ConfigShowSimilarEntries, ConfigShowTable } - diff --git a/man/ConfigFileOpen.Rd b/man/ConfigFileOpen.Rd index eee183f..893900b 100644 --- a/man/ConfigFileOpen.Rd +++ b/man/ConfigFileOpen.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ConfigFileOpen.R \name{ConfigFileOpen} -\alias{ConfigFileCreate} \alias{ConfigFileOpen} +\alias{ConfigFileCreate} \alias{ConfigFileSave} \title{Functions To Create Open And Save Configuration File} \usage{ @@ -194,4 +194,3 @@ ConfigFileSave(configuration, config_file, confirm = FALSE) ConfigApplyMatchingEntries, ConfigEditDefinition, ConfigEditEntry, ConfigFileOpen, ConfigShowSimilarEntries, ConfigShowTable } - diff --git a/man/ConfigShowSimilarEntries.Rd b/man/ConfigShowSimilarEntries.Rd index b9f80ce..72b77e1 100644 --- a/man/ConfigShowSimilarEntries.Rd +++ b/man/ConfigShowSimilarEntries.Rd @@ -4,10 +4,18 @@ \alias{ConfigShowSimilarEntries} \title{Find Similar Entries In Tables Of Datasets} \usage{ -ConfigShowSimilarEntries(configuration, dataset_name = NULL, - var_name = NULL, main_path = NULL, file_path = NULL, - nc_var_name = NULL, suffix = NULL, varmin = NULL, varmax = NULL, - n_results = 10) +ConfigShowSimilarEntries( + configuration, + dataset_name = NULL, + var_name = NULL, + main_path = NULL, + file_path = NULL, + nc_var_name = NULL, + suffix = NULL, + varmin = NULL, + varmax = NULL, + n_results = 10 +) } \arguments{ \item{configuration}{Configuration object obtained either from @@ -79,4 +87,3 @@ ConfigShowSimilarEntries(configuration, dataset_name = "Exper", ConfigApplyMatchingEntries, ConfigEditDefinition, ConfigEditEntry, ConfigFileOpen, ConfigShowSimilarEntries, ConfigShowTable } - diff --git a/man/ConfigShowTable.Rd b/man/ConfigShowTable.Rd index 7c08053..5e4172a 100644 --- a/man/ConfigShowTable.Rd +++ b/man/ConfigShowTable.Rd @@ -1,8 +1,8 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ConfigShowTable.R \name{ConfigShowTable} -\alias{ConfigShowDefinitions} \alias{ConfigShowTable} +\alias{ConfigShowDefinitions} \title{Show Configuration Tables And Definitions} \usage{ ConfigShowTable(configuration, dataset_type, line_numbers = NULL) @@ -54,4 +54,3 @@ ConfigShowDefinitions(configuration) [ConfigEditEntry()], [ConfigFileOpen()], [ConfigShowSimilarEntries()], [ConfigShowTable()]. } - diff --git a/man/Corr.Rd b/man/Corr.Rd index bf5575e..9c20ec1 100644 --- a/man/Corr.Rd +++ b/man/Corr.Rd @@ -4,9 +4,19 @@ \alias{Corr} \title{Compute the correlation coefficient between an array of forecast and their corresponding observation} \usage{ -Corr(exp, obs, time_dim = "sdate", dat_dim = "dataset", comp_dim = NULL, - limits = NULL, method = "pearson", pval = TRUE, conf = TRUE, - conf.lev = 0.95, ncores = NULL) +Corr( + exp, + obs, + time_dim = "sdate", + dat_dim = "dataset", + 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 @@ -86,4 +96,3 @@ corr <- Corr(clim$clim_exp, clim$clim_obs, time_dim = 'ftime', dat_dim = 'member # Renew the example when Ano and Smoothing is ready } - diff --git a/man/EOF.Rd b/man/EOF.Rd index a81f779..32fd999 100644 --- a/man/EOF.Rd +++ b/man/EOF.Rd @@ -4,8 +4,16 @@ \alias{EOF} \title{Area-weighted empirical orthogonal function analysis using SVD} \usage{ -EOF(ano, lat, lon, time_dim = "sdate", space_dim = c("lat", "lon"), - neofs = 15, corr = FALSE, ncores = NULL) +EOF( + ano, + lat, + lon, + time_dim = "sdate", + space_dim = c("lat", "lon"), + neofs = 15, + corr = FALSE, + ncores = NULL +) } \arguments{ \item{ano}{A numerical array of anomalies with named dimensions to calculate @@ -81,7 +89,7 @@ sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), lonmin = -12, lonmax = 40) } ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -tmp <- MeanDims(ano$ano_exp, c('dataset', 'member')) +tmp <- MeanDims(ano$exp, c('dataset', 'member')) ano <- tmp[, 1, ,] names(dim(ano)) <- names(dim(tmp))[-2] eof <- EOF(ano, sampleData$lat, sampleData$lon) @@ -93,4 +101,3 @@ PlotEquiMap(eof$EOFs[1, , ], sampleData$lon, sampleData$lat) \seealso{ ProjectField, NAO, PlotBoxWhisker } - diff --git a/man/Eno.Rd b/man/Eno.Rd index 32468bd..03c3b4f 100644 --- a/man/Eno.Rd +++ b/man/Eno.Rd @@ -39,4 +39,3 @@ data[na] <- NA res <- Eno(data) } - diff --git a/man/GMST.Rd b/man/GMST.Rd index 208ff75..03d1092 100644 --- a/man/GMST.Rd +++ b/man/GMST.Rd @@ -4,10 +4,25 @@ \alias{GMST} \title{Compute the Global Mean Surface Temperature (GMST) anomalies} \usage{ -GMST(data_tas, data_tos, data_lats, data_lons, mask_sea_land, sea_value, type, - mask = NULL, lat_dim = "lat", lon_dim = "lon", monini = 11, - fmonth_dim = "fmonth", sdate_dim = "sdate", indices_for_clim = NULL, - year_dim = "year", month_dim = "month", member_dim = "member") +GMST( + data_tas, + data_tos, + data_lats, + data_lons, + mask_sea_land, + sea_value, + type, + mask = NULL, + lat_dim = "lat", + lon_dim = "lon", + monini = 11, + fmonth_dim = "fmonth", + sdate_dim = "sdate", + indices_for_clim = NULL, + year_dim = "year", + month_dim = "month", + member_dim = "member" +) } \arguments{ \item{data_tas}{A numerical array indicating the surface air temperature data @@ -134,4 +149,3 @@ index_dcpp <- GMST(data_tas = dcpp_tas, data_tos = dcpp_tos, data_lats = lat, sea_value = sea_value) } - diff --git a/man/GSAT.Rd b/man/GSAT.Rd index 9d3fbb6..370900d 100644 --- a/man/GSAT.Rd +++ b/man/GSAT.Rd @@ -4,10 +4,22 @@ \alias{GSAT} \title{Compute the Global Surface Air Temperature (GSAT) anomalies} \usage{ -GSAT(data, data_lats, data_lons, type, lat_dim = "lat", lon_dim = "lon", - mask = NULL, monini = 11, fmonth_dim = "fmonth", sdate_dim = "sdate", - indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member") +GSAT( + data, + data_lats, + data_lons, + type, + lat_dim = "lat", + lon_dim = "lon", + mask = NULL, + monini = 11, + fmonth_dim = "fmonth", + sdate_dim = "sdate", + indices_for_clim = NULL, + year_dim = "year", + month_dim = "month", + member_dim = "member" +) } \arguments{ \item{data}{A numerical array to be used for the index computation with the @@ -101,4 +113,3 @@ lon <- seq(0, 360, 10) index_dcpp <- GSAT(data = dcpp, data_lats = lat, data_lons = lon, type = 'dcpp', monini = 1) } - diff --git a/man/InsertDim.Rd b/man/InsertDim.Rd index 8ab628d..c0dd7d8 100644 --- a/man/InsertDim.Rd +++ b/man/InsertDim.Rd @@ -32,4 +32,3 @@ res <- InsertDim(InsertDim(a, posdim = 2, lendim = 1, name = 'e'), 4, c(f = 2)) dim(res) } - diff --git a/man/LeapYear.Rd b/man/LeapYear.Rd index d261b0a..c2960f3 100644 --- a/man/LeapYear.Rd +++ b/man/LeapYear.Rd @@ -21,4 +21,3 @@ print(LeapYear(1991)) print(LeapYear(1992)) print(LeapYear(1993)) } - diff --git a/man/Load.Rd b/man/Load.Rd index 214f984..10c03f9 100644 --- a/man/Load.Rd +++ b/man/Load.Rd @@ -4,15 +4,36 @@ \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") +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 @@ -874,4 +895,3 @@ sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), lonmin = -12, lonmax = 40) } } - diff --git a/man/MeanDims.Rd b/man/MeanDims.Rd index adff306..9c874fc 100644 --- a/man/MeanDims.Rd +++ b/man/MeanDims.Rd @@ -39,4 +39,3 @@ History:\cr 3.0 - 2020-01 (A. Ho, \email{an.ho@bsc.es}) - Preserve dimension names } \keyword{datagen} - diff --git a/man/Persistence.Rd b/man/Persistence.Rd index 33d4868..3582633 100644 --- a/man/Persistence.Rd +++ b/man/Persistence.Rd @@ -4,9 +4,19 @@ \alias{Persistence} \title{Compute persistence} \usage{ -Persistence(data, dates, time_dim = "time", start, end, ft_start, - ft_end = ft_start, max_ft = 10, nmemb = 1, na.action = 10, - ncores = NULL) +Persistence( + data, + dates, + time_dim = "time", + start, + end, + ft_start, + ft_end = ft_start, + max_ft = 10, + nmemb = 1, + na.action = 10, + ncores = NULL +) } \arguments{ \item{data}{A numeric array corresponding to the observational data @@ -98,4 +108,3 @@ persist <- Persistence(obs1, dates = dates, start = 1961, end = 2005, ft_start = nmemb = 40) } - diff --git a/man/PlotAno.Rd b/man/PlotAno.Rd index 18bf0c9..6591ef1 100644 --- a/man/PlotAno.Rd +++ b/man/PlotAno.Rd @@ -4,12 +4,30 @@ \alias{PlotAno} \title{Plot Anomaly time series} \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 = NULL, width = 8, height = 5, size_units = "in", res = 100, - ...) +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 = NULL, + width = 8, + height = 5, + size_units = "in", + res = 100, + ... +) } \arguments{ \item{exp_ano}{A numerical array containing the experimental data:\cr @@ -100,4 +118,3 @@ PlotAno(smooth_ano_exp, smooth_ano_obs, startDates, legends = 'ERSST', biglab = FALSE) } - diff --git a/man/PlotClim.Rd b/man/PlotClim.Rd index b62ff44..9b3381e 100644 --- a/man/PlotClim.Rd +++ b/man/PlotClim.Rd @@ -4,11 +4,26 @@ \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 = NULL, width = 8, height = 5, - size_units = "in", res = 100, ...) +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 = NULL, + width = 8, + height = 5, + size_units = "in", + res = 100, + ... +) } \arguments{ \item{exp_clim}{Matrix containing the experimental data with dimensions:\cr @@ -79,4 +94,3 @@ PlotClim(clim$clim_exp, clim$clim_obs, toptitle = paste('climatologies'), listobs = c('ERSST'), biglab = FALSE, fileout = NULL) } - diff --git a/man/PlotEquiMap.Rd b/man/PlotEquiMap.Rd index cf45ead..fbd7042 100644 --- a/man/PlotEquiMap.Rd +++ b/man/PlotEquiMap.Rd @@ -4,25 +4,72 @@ \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, - ...) +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 @@ -278,4 +325,3 @@ 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) } - diff --git a/man/PlotLayout.Rd b/man/PlotLayout.Rd index f01fdf9..453cf2e 100644 --- a/man/PlotLayout.Rd +++ b/man/PlotLayout.Rd @@ -4,20 +4,52 @@ \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) +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 @@ -48,6 +80,12 @@ 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{\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'.} + \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 @@ -164,12 +202,6 @@ 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}{ @@ -244,4 +276,3 @@ PlotLayout(PlotEquiMap, c('lat', 'lon'), sampleData$mod[1, , 1, 1, , ], titles = paste('Member', 1:15)) } - diff --git a/man/PlotMatrix.Rd b/man/PlotMatrix.Rd index 24f046d..5275df0 100644 --- a/man/PlotMatrix.Rd +++ b/man/PlotMatrix.Rd @@ -4,12 +4,28 @@ \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, ...) +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 @@ -93,4 +109,3 @@ PlotMatrix(var = matrix(rnorm(n = 120, mean = 0.3), 10, 12), xlabels = c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")) } - diff --git a/man/PlotSection.Rd b/man/PlotSection.Rd index 413ef63..1627339 100644 --- a/man/PlotSection.Rd +++ b/man/PlotSection.Rd @@ -4,10 +4,26 @@ \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, ...) +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.} @@ -69,4 +85,3 @@ sampleData <- s2dv::sampleDepthData PlotSection(sampleData$mod[1, 1, 1, 1, , ], sampleData$lat, sampleData$depth, toptitle = 'temperature 1995-11 member 0') } - diff --git a/man/PlotStereoMap.Rd b/man/PlotStereoMap.Rd index 4b910a9..95c2f71 100644 --- a/man/PlotStereoMap.Rd +++ b/man/PlotStereoMap.Rd @@ -4,19 +4,53 @@ \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, ...) +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 @@ -183,4 +217,3 @@ y <- seq(from = -90, to = 90, length.out = 50) PlotStereoMap(data, x, y, latlims = c(60, 90), brks = 50, toptitle = "This is the title") } - diff --git a/man/ProjectField.Rd b/man/ProjectField.Rd index 198db05..d2bd9fb 100644 --- a/man/ProjectField.Rd +++ b/man/ProjectField.Rd @@ -4,16 +4,22 @@ \alias{ProjectField} \title{Project anomalies onto modes of variability} \usage{ -ProjectField(ano, lat, lon, time_dim = "sdate", space_dim = c("lat", "lon"), - mode = 1, ncores = NULL) +ProjectField( + ano, + eof, + time_dim = "sdate", + space_dim = c("lat", "lon"), + mode = 1, + ncores = NULL +) } \arguments{ \item{ano}{A numerical array of anomalies with named dimensions. The dimensions must have at least 'time_dim' and 'space_dim'.} -\item{lat}{A vector of the latitudes of 'ano' to calculate EOF.} - -\item{lon}{A vector of the longitudes of 'ano' to calculate EOF.} +\item{eof}{A list contains at least 'EOFs' and 'wght', which are both arrays. +'EOFs' has dimensions same as 'ano' except 'EOFs' has 'mode' and 'ano' has + time_dim. 'wght' has dimensions space_dim. It can be generated by EOF().} \item{time_dim}{A character string indicating the name of the time dimension of 'ano'. The default value is 'sdate'.} @@ -50,8 +56,10 @@ sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), lonmin = -12, lonmax = 40) } ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -mode1_exp <- ProjectField(ano$ano_exp, sampleData$lat, sampleData$lon) -mode1_obs <- ProjectField(ano$ano_obs, sampleData$lat, sampleData$lon) +eof_exp <- EOF(ano$exp, sampleData$lat, sampleData$lon) +eof_obs <- EOF(ano$obs, sampleData$lat, sampleData$lon) +mode1_exp <- ProjectField(ano$exp, eof_exp) +mode1_obs <- ProjectField(ano$obs, eof_obs) \dontrun{ # Plot the forecast and the observation of the first mode for the last year @@ -70,4 +78,3 @@ mode1_obs <- ProjectField(ano$ano_obs, sampleData$lat, sampleData$lon) \seealso{ EOF, NAO, PlotBoxWhisker } - diff --git a/man/RMS.Rd b/man/RMS.Rd index 7bd33b3..4391df4 100644 --- a/man/RMS.Rd +++ b/man/RMS.Rd @@ -4,8 +4,17 @@ \alias{RMS} \title{Compute root mean square error} \usage{ -RMS(exp, obs, time_dim = "sdate", dat_dim = "dataset", comp_dim = NULL, - limits = NULL, conf = TRUE, conf.lev = 0.95, ncores = NULL) +RMS( + exp, + obs, + time_dim = "sdate", + dat_dim = "dataset", + 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 @@ -79,4 +88,3 @@ The confidence interval is computed by the chi2 distribution.\cr # Renew example when Ano and Smoothing are ready } - diff --git a/man/RMSSS.Rd b/man/RMSSS.Rd index 1b8274f..9ebcf65 100644 --- a/man/RMSSS.Rd +++ b/man/RMSSS.Rd @@ -4,8 +4,14 @@ \alias{RMSSS} \title{Compute root mean square error skill score} \usage{ -RMSSS(exp, obs, time_dim = "sdate", dat_dim = "dataset", pval = TRUE, - ncores = NULL) +RMSSS( + exp, + obs, + time_dim = "sdate", + dat_dim = "dataset", + pval = TRUE, + ncores = NULL +) } \arguments{ \item{exp}{A named numeric array of experimental data which contains at least @@ -66,4 +72,3 @@ obs <- array(rnorm(15), dim = c(time = 3, memb = 5, dataset = 1)) res <- RMSSS(exp, obs, time_dim = 'time') } - diff --git a/man/RandomWalkTest.Rd b/man/RandomWalkTest.Rd index 33b226f..1110648 100644 --- a/man/RandomWalkTest.Rd +++ b/man/RandomWalkTest.Rd @@ -49,4 +49,3 @@ skill_B <- abs(fcst_B - reference) RandomWalkTest(skill_A = skill_A, skill_B = skill_B, time_dim = 'sdate', ncores = 1) } - diff --git a/man/Regression.Rd b/man/Regression.Rd index 4faafc1..8e27295 100644 --- a/man/Regression.Rd +++ b/man/Regression.Rd @@ -4,8 +4,17 @@ \alias{Regression} \title{Compute the regression of an array on another along one dimension.} \usage{ -Regression(datay, datax, reg_dim = "sdate", formula = y ~ x, pval = TRUE, - conf = TRUE, conf.lev = 0.95, na.action = na.omit, ncores = NULL) +Regression( + datay, + datax, + reg_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 @@ -92,4 +101,3 @@ res1 <- Regression(datay, datax, formula = y~poly(x, 2, raw = TRUE)) res2 <- Regression(datay, datax, conf.lev = 0.9) } - diff --git a/man/Reorder.Rd b/man/Reorder.Rd index 0afa07e..8748aaf 100644 --- a/man/Reorder.Rd +++ b/man/Reorder.Rd @@ -26,4 +26,3 @@ Reorder the dimension order of a multi-dimensional array dat2 <- array(c(1:10), dim = c(2, 1, 5)) print(dim(Reorder(dat2, c(2, 1, 3)))) } - diff --git a/man/SPOD.Rd b/man/SPOD.Rd index cbbbf1a..5a20a3f 100644 --- a/man/SPOD.Rd +++ b/man/SPOD.Rd @@ -4,10 +4,22 @@ \alias{SPOD} \title{Compute the South Pacific Ocean Dipole (SPOD) index} \usage{ -SPOD(data, data_lats, data_lons, type, lat_dim = "lat", lon_dim = "lon", - mask = NULL, monini = 11, fmonth_dim = "fmonth", sdate_dim = "sdate", - indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member") +SPOD( + data, + data_lats, + data_lons, + type, + lat_dim = "lat", + lon_dim = "lon", + mask = NULL, + monini = 11, + fmonth_dim = "fmonth", + sdate_dim = "sdate", + indices_for_clim = NULL, + year_dim = "year", + month_dim = "month", + member_dim = "member" +) } \arguments{ \item{data}{A numerical array to be used for the index computation with the @@ -104,4 +116,3 @@ lon <- seq(0, 360, 10) index_dcpp <- SPOD(data = dcpp, data_lats = lat, data_lons = lon, type = 'dcpp', monini = 1) } - diff --git a/man/Season.Rd b/man/Season.Rd index cb10dee..3c1e3ff 100644 --- a/man/Season.Rd +++ b/man/Season.Rd @@ -4,8 +4,16 @@ \alias{Season} \title{Compute seasonal mean} \usage{ -Season(data, time_dim = "ftime", monini, moninf, monsup, method = mean, - na.rm = TRUE, ncores = NULL) +Season( + data, + time_dim = "ftime", + monini, + moninf, + monsup, + method = mean, + na.rm = TRUE, + ncores = NULL +) } \arguments{ \item{data}{A named numeric array with at least one dimension 'time_dim'.} @@ -53,4 +61,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/Smoothing.Rd b/man/Smoothing.Rd index ba62ca1..8d4a558 100644 --- a/man/Smoothing.Rd +++ b/man/Smoothing.Rd @@ -43,4 +43,3 @@ PlotAno(smooth_ano_exp, smooth_ano_obs, startDates, fileout = "tos_smoothed_ano.png") } } - diff --git a/man/TPI.Rd b/man/TPI.Rd index 6968f22..fdbc2b8 100644 --- a/man/TPI.Rd +++ b/man/TPI.Rd @@ -4,10 +4,22 @@ \alias{TPI} \title{Compute the Tripole Index (TPI) for the Interdecadal Pacific Oscillation (IPO)} \usage{ -TPI(data, data_lats, data_lons, type, lat_dim = "lat", lon_dim = "lon", - mask = NULL, monini = 11, fmonth_dim = "fmonth", sdate_dim = "sdate", - indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member") +TPI( + data, + data_lats, + data_lons, + type, + lat_dim = "lat", + lon_dim = "lon", + mask = NULL, + monini = 11, + fmonth_dim = "fmonth", + sdate_dim = "sdate", + indices_for_clim = NULL, + year_dim = "year", + month_dim = "month", + member_dim = "member" +) } \arguments{ \item{data}{A numerical array to be used for the index computation with the @@ -103,4 +115,3 @@ lon = seq(0, 360, 10) index_dcpp = TPI(data = dcpp, data_lats = lat, data_lons = lon, type = 'dcpp', monini = 1) } - diff --git a/man/ToyModel.Rd b/man/ToyModel.Rd index 379ed3b..ee7a98e 100644 --- a/man/ToyModel.Rd +++ b/man/ToyModel.Rd @@ -7,8 +7,18 @@ 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) +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 @@ -120,4 +130,3 @@ toyforecast <- ToyModel(alpha = a, beta = b, gamma = g, nmemb = nm, # } } - diff --git a/man/Trend.Rd b/man/Trend.Rd index a641041..d283ee6 100644 --- a/man/Trend.Rd +++ b/man/Trend.Rd @@ -4,8 +4,16 @@ \alias{Trend} \title{Compute the trend} \usage{ -Trend(data, time_dim = "ftime", interval = 1, polydeg = 1, conf = TRUE, - conf.lev = 0.95, pval = TRUE, ncores = NULL) +Trend( + data, + time_dim = "ftime", + interval = 1, + polydeg = 1, + conf = TRUE, + conf.lev = 0.95, + pval = TRUE, + ncores = NULL +) } \arguments{ \item{data}{An numeric array including the dimension along which the trend @@ -80,4 +88,3 @@ months_between_startdates <- 60 trend <- Trend(sampleData$obs, polydeg = 2, interval = months_between_startdates) } - diff --git a/man/clim.palette.Rd b/man/clim.palette.Rd index d912f47..5d17947 100644 --- a/man/clim.palette.Rd +++ b/man/clim.palette.Rd @@ -1,8 +1,8 @@ % 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} +\alias{clim.colors} \title{Generate Climate Color Palettes} \usage{ clim.palette(palette = "bluered") @@ -30,4 +30,3 @@ cols <- clim.colors(20) ColorBar(lims, cols) } - diff --git a/man/s2dv-package.Rd b/man/s2dv-package.Rd index cb52214..043b081 100644 --- a/man/s2dv-package.Rd +++ b/man/s2dv-package.Rd @@ -4,20 +4,45 @@ \name{s2dv-package} \alias{s2dv} \alias{s2dv-package} -\title{A Set of Common Tools for Seasonal to Decadal Verification} +\title{s2dv: A Set of Common Tools for Seasonal to Decadal Verification} \description{ -The advanced version of package 's2dverification'. It is -intended for 'seasonal to decadal' (s2d) climate forecast verification, but -it can also be used in other kinds of forecasts or general climate analysis. -This package is specially designed for the comparison between the experimental -and observational datasets. The functionality of the included functions covers -from data retrieval, data post-processing, skill scores against observation, -to visualization. Compared to 's2dverification', 's2dv' is more compatible -with the package 'startR', able to use multiple cores for computation and -handle multi-dimensional arrays with a higher flexibility. +The advanced version of package 's2dverification'. It is + intended for 'seasonal to decadal' (s2d) climate forecast verification, but + it can also be used in other kinds of forecasts or general climate analysis. + This package is specially designed for the comparison between the experimental + and observational datasets. The functionality of the included functions covers + from data retrieval, data post-processing, skill scores against observation, + to visualization. Compared to 's2dverification', 's2dv' is more compatible + with the package 'startR', able to use multiple cores for computation and + handle multi-dimensional arrays with a higher flexibility. } \references{ \url{https://earth.bsc.es/gitlab/es/s2dv/} } -\keyword{internal} +\seealso{ +Useful links: +\itemize{ + \item \url{https://earth.bsc.es/gitlab/es/s2dv/} + \item Report bugs at \url{https://earth.bsc.es/gitlab/es/s2dv/-/issues} +} + +} +\author{ +\strong{Maintainer}: An-Chi Ho \email{an.ho@bsc.es} + +Authors: +\itemize{ + \item BSC-CNS [copyright holder] + \item Nuria Perez-Zanon \email{nuria.perez@bsc.es} +} + +Other contributors: +\itemize{ + \item Roberto Bilbao \email{roberto.bilbao@bsc.es} [contributor] + \item Carlos Delgado \email{carlos.delgado@bsc.es} [contributor] + \item Andrea Manrique \email{andrea.manrique@bsc.es} [contributor] + \item Deborah Verfaillie \email{deborah.verfaillie@bsc.es} [contributor] +} +} +\keyword{internal} diff --git a/man/sampleDepthData.Rd b/man/sampleDepthData.Rd index 869af86..77e4a7a 100644 --- a/man/sampleDepthData.Rd +++ b/man/sampleDepthData.Rd @@ -28,4 +28,3 @@ variable 'tos', i.e. sea surface temperature, from the decadal climate prediction experiment run at IC3 in the context of the CMIP5 project.\cr Its name within IC3 local database is 'i00k'. } - diff --git a/man/sampleMap.Rd b/man/sampleMap.Rd index 651d185..eaf8aa5 100644 --- a/man/sampleMap.Rd +++ b/man/sampleMap.Rd @@ -43,4 +43,3 @@ sampleData <- Load('tos', list(exp), list(obs), startDates, } Check the documentation on 'Load()' in the package 's2dv' for more information. } - diff --git a/man/sampleTimeSeries.Rd b/man/sampleTimeSeries.Rd index 280277e..05a8e79 100644 --- a/man/sampleTimeSeries.Rd +++ b/man/sampleTimeSeries.Rd @@ -47,4 +47,3 @@ sampleData <- Load('tos', list(exp), list(obs), startDates, } Check the documentation on 'Load()' in the package 's2dv' for more information. } - diff --git a/tests/testthat/test-Ano_CrossValid.R b/tests/testthat/test-Ano_CrossValid.R index 1333f15..52dcf73 100644 --- a/tests/testthat/test-Ano_CrossValid.R +++ b/tests/testthat/test-Ano_CrossValid.R @@ -90,24 +90,24 @@ test_that("2. dat1", { expect_equal( names(Ano_CrossValid(exp1, obs1)), - c("ano_exp", "ano_obs") + c("exp", "obs") ) expect_equal( - dim(Ano_CrossValid(exp1, obs1)$ano_exp), + dim(Ano_CrossValid(exp1, obs1)$exp), c(sdate = 5, dataset = 2, member = 3, ftime = 2) ) expect_equal( - Ano_CrossValid(exp1, obs1)$ano_exp[, 1, 2, 2], + Ano_CrossValid(exp1, obs1)$exp[, 1, 2, 2], c(0.2771331, 1.1675753, -1.0684010, 0.2901759, -0.6664833), tolerance = 0.0001 ) expect_equal( - Ano_CrossValid(exp1, obs1)$ano_obs[, 1, 2, 2], + Ano_CrossValid(exp1, obs1)$obs[, 1, 2, 2], c(1.7024193, -0.8243579, -2.4136080, 0.5199868, 1.0155598), tolerance = 0.0001 ) expect_equal( - Ano_CrossValid(exp1, obs1, memb = FALSE)$ano_exp[, 1, 2, 2], + Ano_CrossValid(exp1, obs1, memb = FALSE)$exp[, 1, 2, 2], c(0.1229714, 0.8496518, -0.9531644, 0.1548713, -0.5264025), tolerance = 0.0001 ) @@ -118,19 +118,19 @@ test_that("2. dat1", { test_that("3. dat2", { expect_equal( names(Ano_CrossValid(exp2, obs2, dat_dim = 'member')), - c("ano_exp", "ano_obs") + c("exp", "obs") ) expect_equal( - dim(Ano_CrossValid(exp2, obs2, dat_dim = 'member')$ano_exp), + dim(Ano_CrossValid(exp2, obs2, dat_dim = 'member')$exp), c(sdate = 5, member = 3, ftime = 2) ) expect_equal( - Ano_CrossValid(exp2, obs2, dat_dim = 'member')$ano_exp[, 2, 2], + Ano_CrossValid(exp2, obs2, dat_dim = 'member')$exp[, 2, 2], c(0.05650631, 1.53434806, -0.37561623, -0.26217217, -0.95306597), tolerance = 0.0001 ) expect_equal( - Ano_CrossValid(exp2, obs2, dat_dim = 'member', memb = FALSE)$ano_exp[, 2, 2], + Ano_CrossValid(exp2, obs2, dat_dim = 'member', memb = FALSE)$exp[, 2, 2], c(0.34489635, 1.56816273, -0.01926901, -0.09646066, -0.68236823), tolerance = 0.0001 ) -- GitLab From 5eba00394f52f614a7b42a15e4f68ea7d28fd74b Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 12 Feb 2021 09:55:45 +0100 Subject: [PATCH 09/28] Specify the package name of Subset() to avoid confusion. --- R/Ano_CrossValid.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index e4a8b77..f00a267 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -208,8 +208,8 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', } } # calculate ano - ano_exp_list[[tt]] <- Subset(exp, 1, tt, drop = 'selected') - clim_exp - ano_obs_list[[tt]] <- Subset(obs, 1, tt, drop = 'selected') - clim_obs + ano_exp_list[[tt]] <- ClimProjDiags::Subset(exp, 1, tt, drop = 'selected') - clim_exp + ano_obs_list[[tt]] <- ClimProjDiags::Subset(obs, 1, tt, drop = 'selected') - clim_obs } ano_exp <- array(unlist(ano_exp_list), dim = c(dim(exp)[-1], dim(exp)[1])) -- GitLab From 800216dc7a502fee73dc9e2a9218c484a2fb5d58 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 18 Mar 2021 14:25:46 +0100 Subject: [PATCH 10/28] Supplement the method explanation for Ano_CrossValid and the explanation for the general named dimension usage in README --- R/Ano_CrossValid.R | 11 ++++++++--- README.md | 21 +++++++++++++++++++++ man/Ano_CrossValid.Rd | 9 +++++++-- 3 files changed, 36 insertions(+), 5 deletions(-) diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index f00a267..3cfc424 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -1,8 +1,13 @@ #'Compute anomalies in cross-validation mode #' #'Compute the anomalies from the arrays of the experimental and observational -#'data output by subtracting the climatologies computed with a cross-validation -#'technique and a per-pair method. +#'data output by subtracting the climatologies computed with a leave-one-out +#'cross validation technique and a per-pair method (Garcia-Serrano and +#'Doblas-Reyes, CD, 2012). +#'Per-pair climatology means that only the start dates covered by the +#'whole experiments/observational datasets will be used. In other words, the +#'startdates which do not all have values 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 #' dimensions 'time_dim' and 'dat_dim'. @@ -129,7 +134,7 @@ Ano_CrossValid <- function(exp, obs, time_dim = 'sdate', dat_dim = c('dataset', } #----------------------------------- - # Per-paired method: Remove all sdate if not complete along dat_dim + # Per-paired method: If any sdate along dat_dim is NA, turn all sdate points along dat_dim into NA. pos <- rep(0, length(dat_dim)) # dat_dim: [dataset, member] for (i in 1:length(dat_dim)) { pos[i] <- which(names(dim(obs)) == dat_dim[i]) diff --git a/README.md b/README.md index f9cce38..63b261d 100644 --- a/README.md +++ b/README.md @@ -64,6 +64,27 @@ correlation with reliability indicators such as p-values and confidence interval - **Visualization** module: Plotting functions are also provided to plot the results obtained from any of the modules above. +One important feature of s2dv is the named dimension of the data array. All the +data input of the functions should have names for all the dimensions. It should +not be a problem since the data retrieved by s2dv::Load or startR::Start have +named dimension inherently. Take the sample data in s2dv as an example: +```r +sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), c('observation'), + '19901101', leadtimemin = 1, leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) +# It returns an object 'sampleData' +dim(sampleData$mod) +dataset member sdate ftime lat lon + 1 3 1 4 2 3 +dim(sampleData$obs) +dataset member sdate ftime lat lon + 1 1 1 4 2 3 +``` +The feature provides security during the analysis, ensuring that the dimensions +under operation are the desired ones. + Contribute ---------- diff --git a/man/Ano_CrossValid.Rd b/man/Ano_CrossValid.Rd index bef1524..e0123d2 100644 --- a/man/Ano_CrossValid.Rd +++ b/man/Ano_CrossValid.Rd @@ -54,8 +54,13 @@ A list of 2: } \description{ Compute the anomalies from the arrays of the experimental and observational -data output by subtracting the climatologies computed with a cross-validation -technique and a per-pair method. +data output by subtracting the climatologies computed with a leave-one-out +cross validation technique and a per-pair method (Garcia-Serrano and +Doblas-Reyes, CD, 2012). +Per-pair climatology means that only the start dates covered by the +whole experiments/observational datasets will be used. In other words, the +startdates which do not all have values along 'dat_dim' dimension of both +the 'exp' and 'obs' are excluded when computing the climatologies. } \examples{ # Load sample data as in Load() example: -- GitLab From 63811c7fb3865b64c7c2a92c1d40f16713045df6 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 18 Mar 2021 16:06:10 +0100 Subject: [PATCH 11/28] Improve documentation of param 'memb'. --- R/Ano_CrossValid.R | 6 +++--- man/Ano_CrossValid.Rd | 5 ++--- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index 3cfc424..f625ccc 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -23,9 +23,9 @@ #'@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) when calculating -#' climatology. The default value is TRUE. +#'@param memb A logical value indicating whether to subtract the climatology +#' based on the individual members (TRUE) or the ensemble mean over all +# members (FALSE) when calculating the anomalies. The default value is TRUE. #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' diff --git a/man/Ano_CrossValid.Rd b/man/Ano_CrossValid.Rd index e0123d2..3fe1e60 100644 --- a/man/Ano_CrossValid.Rd +++ b/man/Ano_CrossValid.Rd @@ -34,9 +34,8 @@ along 'dat_dim' will be discarded. The default value is 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) when calculating -climatology. The default value is TRUE.} +\item{memb}{A logical value indicating whether to subtract the climatology +based on the individual members (TRUE) or the ensemble mean over all} \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} -- GitLab From 4144a32a6690fd28ffa18c4f7a130af1d635a06f Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 30 Mar 2021 11:04:19 +0200 Subject: [PATCH 12/28] Update indices function .md file, and revise EOF documentation for params 'weights' and 'mask'. --- R/EOF.R | 16 +++++++++++----- man/AMV.Rd | 29 ++++++++++++++--------------- man/EOF.Rd | 16 +++++++++++----- man/GMST.Rd | 51 ++++++++++++++++++++++++--------------------------- man/GSAT.Rd | 30 +++++++++++++++--------------- man/SPOD.Rd | 30 +++++++++++++++--------------- man/TPI.Rd | 30 +++++++++++++++--------------- 7 files changed, 105 insertions(+), 97 deletions(-) diff --git a/R/EOF.R b/R/EOF.R index c595d4b..f37fa8f 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -44,17 +44,23 @@ #'} #'\item{mask}{ #' An array of the mask with dimensions (space_dim, rest of the dimension -#' except 'time_dim'). +#' except 'time_dim'). It is made from 'ano', 1 for the positions that 'ano' +#' has value and NA for the positions that 'ano' has NA. It is used to +#' replace NAs with 0s for EOF calculation and mask the result with NAs again +#' after the calculation. #'} #'\item{wght}{ -#' An array of the weights with dimensions (space_dim). +#' An array of the area weighting with dimensions 'space_dim'. It is calculated +#' by cosine of 'lat' and used to compute the fraction of variance explained by +#' each EOFs. #'} #' #'@seealso ProjectField, NAO, PlotBoxWhisker #'@examples -#'# This example computes the EOFs along forecast horizons and plots the one that -#'# explains the greatest amount of variability. The example data is very low -#'# resolution so it does not make a lot of sense. +#'# This example computes the EOFs along forecast horizons and plots the one +#'# that explains the greatest amount of variability. The example data has low +#'# resolution so the result may not be explanatory, but it displays how to +#'# use this function. #'\dontshow{ #'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') #'sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), diff --git a/man/AMV.Rd b/man/AMV.Rd index 0f81652..3cc4113 100644 --- a/man/AMV.Rd +++ b/man/AMV.Rd @@ -18,16 +18,15 @@ AMV( indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member", + na.rm = TRUE, ncores = NULL ) } \arguments{ -\item{data}{A numerical array to be used for the index computation with the -dimensions: 1) latitude, longitude, start date, forecast month, and member -(in case of decadal predictions), 2) latitude, longitude, year, month and -member (in case of historical simulations), or 3) latitude, longitude, year -and month (in case of observations or reanalyses). This data has to be +\item{data}{A numerical array to be used for the index computation with, at least, the +dimensions: 1) latitude, longitude, start date and forecast month +(in case of decadal predictions), 2) latitude, longitude, year and month +(in case of historical simulations or observations). This data has to be provided, at least, over the whole region needed to compute the index.} \item{data_lats}{A numeric vector indicating the latitudes of the data.} @@ -70,7 +69,7 @@ climatology is calculated over the whole period. If the data are already anomalies, set it to FALSE. The default value is NULL.\cr In case of parameter 'type' is 'dcpp', 'indices_for_clim' must be relative to the first forecast year, and the climatology is automatically computed -over the actual common period for the different forecast years.} +over the common calendar period for the different forecast years.} \item{year_dim}{A character string indicating the name of the year dimension The default value is 'year'. Only used if parameter 'type' is 'hist' or @@ -80,18 +79,17 @@ The default value is 'year'. Only used if parameter 'type' is 'hist' or dimension. The default value is 'month'. Only used if parameter 'type' is 'hist' or 'obs'.} -\item{member_dim}{A character string indicating the name of the member -dimension. The default value is 'member'. Only used if parameter 'type' is -'dcpp' or 'hist'.} +\item{na.rm}{A logical value indicanting whether to remove NA values. 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 numerical array of the AMV index with the dimensions of: - 1) sdate, forecast year, and member (in case of decadal predictions); - 2) year and member (in case of historical simulations); or - 3) year (in case of observations or reanalyses). +A numerical array with the AMV index with the same dimensions as data except + the lat_dim, lon_dim and fmonth_dim (month_dim) in case of decadal predictions + (historical simulations or observations). In case of decadal predictions, a new dimension + 'fyear' is added. } \description{ The Atlantic Multidecadal Variability (AMV), also known as Atlantic @@ -100,7 +98,8 @@ surface temperatures (SST) over the North Atlantic Ocean on multi-decadal time scales. The AMV index is computed as the difference of weighted-averaged SST anomalies over the North Atlantic region (0ºN-60ºN, 280ºE-360ºE) and the weighted-averaged SST anomalies over 60ºS-60ºN, 0ºE-360ºE (Trenberth & -Dennis, 2005; Doblas-Reyes et al., 2013). +Dennis, 2005; Doblas-Reyes et al., 2013). If different members and/or datasets are provided, +the climatology (used to calculate the anomalies) is computed individually for all of them. } \examples{ ## Observations or reanalyses diff --git a/man/EOF.Rd b/man/EOF.Rd index 32fd999..b460cd5 100644 --- a/man/EOF.Rd +++ b/man/EOF.Rd @@ -63,10 +63,15 @@ A list containing: } \item{mask}{ An array of the mask with dimensions (space_dim, rest of the dimension - except 'time_dim'). + except 'time_dim'). It is made from 'ano', 1 for the positions that 'ano' + has value and NA for the positions that 'ano' has NA. It is used to + replace NAs with 0s for EOF calculation and mask the result with NAs again + after the calculation. } \item{wght}{ - An array of the weights with dimensions (space_dim). + An array of the area weighting with dimensions 'space_dim'. It is calculated + by cosine of 'lat' and used to compute the fraction of variance explained by + each EOFs. } } \description{ @@ -75,9 +80,10 @@ by default, based on the correlation matrix if \code{corr} argument is set to \code{TRUE}. } \examples{ -# This example computes the EOFs along forecast horizons and plots the one that -# explains the greatest amount of variability. The example data is very low -# resolution so it does not make a lot of sense. +# This example computes the EOFs along forecast horizons and plots the one +# that explains the greatest amount of variability. The example data has low +# resolution so the result may not be explanatory, but it displays how to +# use this function. \dontshow{ startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), diff --git a/man/GMST.Rd b/man/GMST.Rd index 8021943..f23e60d 100644 --- a/man/GMST.Rd +++ b/man/GMST.Rd @@ -21,28 +21,25 @@ GMST( indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member", + na.rm = TRUE, ncores = NULL ) } \arguments{ -\item{data_tas}{A numerical array indicating the surface air temperature data -to be used for the index computation with the dimensions: 1) latitude, -longitude, start date, forecast month, and member (in case of decadal -predictions), 2) latitude, longitude, year, month and member (in case of -historical simulations), or 3) latitude, longitude, year and month (in case -of observations or reanalyses). This data has to be provided, at least, -over the whole region needed to compute the index. The dimensions must be -identical to those of data_tos.} - -\item{data_tos}{A numerical array indicating the sea surface temperature data -to be used for the index computation with the dimensions: 1) latitude, -longitude, start date, forecast month, and member (in case of decadal -predictions), 2) latitude, longitude, year, month and member (in case of -historical simulations), or 3) latitude, longitude, year and month (in case -of observations or reanalyses). This data has to be provided, at least, -over the whole region needed to compute the index. The dimensions must be -identical to those of data_tas.} +\item{data_tas}{A numerical array with the surface air temperature data +to be used for the index computation with, at least, the +dimensions: 1) latitude, longitude, start date and forecast month +(in case of decadal predictions), 2) latitude, longitude, year and month +(in case of historical simulations or observations). This data has to be +provided, at least, over the whole region needed to compute the index. +The dimensions must be identical to thos of data_tos. +#'@param data_tos A numerical array with the sea surface temperature data +to be used for the index computation with, at least, the +dimensions: 1) latitude, longitude, start date and forecast month +(in case of decadal predictions), 2) latitude, longitude, year and month +(in case of historical simulations or observations). This data has to be +provided, at least, over the whole region needed to compute the index. +The dimensions must be identical to thos of data_tas.} \item{data_lats}{A numeric vector indicating the latitudes of the data.} @@ -90,7 +87,7 @@ climatology is calculated over the whole period. If the data are already anomalies, set it to FALSE. The default value is NULL.\cr In case of parameter 'type' is 'dcpp', 'indices_for_clim' must be relative to the first forecast year, and the climatology is automatically computed -over the actual common period for the different forecast years.} +over the common calendar period for the different forecast years.} \item{year_dim}{A character string indicating the name of the year dimension The default value is 'year'. Only used if parameter 'type' is 'hist' or @@ -100,23 +97,23 @@ The default value is 'year'. Only used if parameter 'type' is 'hist' or dimension. The default value is 'month'. Only used if parameter 'type' is 'hist' or 'obs'.} -\item{member_dim}{A character string indicating the name of the member -dimension. The default value is 'member'. Only used if parameter 'type' is -'dcpp' or 'hist'.} +\item{na.rm}{A logical value indicanting whether to remove NA values. 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 numerical array of the GMST anomalies with the dimensions of: - 1) sdate, forecast year, and member (in case of decadal predictions); - 2) year and member (in case of historical simulations); or - 3) year (in case of observations or reanalyses). +A numerical array with the GMST anomalies with the same dimensions as data_tas except + the lat_dim, lon_dim and fmonth_dim (month_dim) in case of decadal predictions + (historical simulations or observations). In case of decadal predictions, a new dimension + 'fyear' is added. } \description{ The Global Mean Surface Temperature (GMST) anomalies are computed as the weighted-averaged surface air temperature anomalies over land and sea surface -temperature anomalies over the ocean. +temperature anomalies over the ocean. If different members and/or datasets are provided, +the climatology (used to calculate the anomalies) is computed individually for all of them. } \examples{ ## Observations or reanalyses diff --git a/man/GSAT.Rd b/man/GSAT.Rd index d7fe3cf..9f03ff2 100644 --- a/man/GSAT.Rd +++ b/man/GSAT.Rd @@ -18,16 +18,15 @@ GSAT( indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member", + na.rm = TRUE, ncores = NULL ) } \arguments{ -\item{data}{A numerical array to be used for the index computation with the -dimensions: 1) latitude, longitude, start date, forecast month, and member -(in case of decadal predictions), 2) latitude, longitude, year, month and -member (in case of historical simulations), or 3) latitude, longitude, year -and month (in case of observations or reanalyses). This data has to be +\item{data}{A numerical array to be used for the index computation with, at least, the +dimensions: 1) latitude, longitude, start date and forecast month +(in case of decadal predictions), 2) latitude, longitude, year and month +(in case of historical simulations or observations). This data has to be provided, at least, over the whole region needed to compute the index.} \item{data_lats}{A numeric vector indicating the latitudes of the data.} @@ -70,7 +69,7 @@ climatology is calculated over the whole period. If the data are already anomalies, set it to FALSE. The default value is NULL.\cr In case of parameter 'type' is 'dcpp', 'indices_for_clim' must be relative to the first forecast year, and the climatology is automatically computed -over the actual common period for the different forecast years.} +over the common calendar period for the different forecast years.} \item{year_dim}{A character string indicating the name of the year dimension The default value is 'year'. Only used if parameter 'type' is 'hist' or @@ -80,22 +79,23 @@ The default value is 'year'. Only used if parameter 'type' is 'hist' or dimension. The default value is 'month'. Only used if parameter 'type' is 'hist' or 'obs'.} -\item{member_dim}{A character string indicating the name of the member -dimension. The default value is 'member'. Only used if parameter 'type' is -'dcpp' or 'hist'.} +\item{na.rm}{A logical value indicanting whether to remove NA values. 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 numerical array of the GSAT anomalies with the dimensions of: - 1) sdate, forecast year, and member (in case of decadal predictions); - 2) year and member (in case of historical simulations); or - 3) year (in case of observations or reanalyses). +A numerical array with the GSAT anomalies with the same dimensions as data except + the lat_dim, lon_dim and fmonth_dim (month_dim) in case of decadal predictions + (historical simulations or observations). In case of decadal predictions, a new dimension + 'fyear' is added. } \description{ The Global Surface Air Temperature (GSAT) anomalies are computed as the -weighted-averaged surface air temperature anomalies over the global region. +weighted-averaged surface air temperature anomalies over the global region. +If different members and/or datasets are provided, the climatology (used to +calculate the anomalies) is computed individually for all of them. } \examples{ ## Observations or reanalyses diff --git a/man/SPOD.Rd b/man/SPOD.Rd index 0491739..4c4ed29 100644 --- a/man/SPOD.Rd +++ b/man/SPOD.Rd @@ -18,16 +18,15 @@ SPOD( indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member", + na.rm = TRUE, ncores = NULL ) } \arguments{ -\item{data}{A numerical array to be used for the index computation with the -dimensions: 1) latitude, longitude, start date, forecast month, and member -(in case of decadal predictions), 2) latitude, longitude, year, month and -member (in case of historical simulations), or 3) latitude, longitude, year -and month (in case of observations or reanalyses). This data has to be +\item{data}{A numerical array to be used for the index computation with, at least, the +dimensions: 1) latitude, longitude, start date and forecast month +(in case of decadal predictions), 2) latitude, longitude, year and month +(in case of historical simulations or observations). This data has to be provided, at least, over the whole region needed to compute the index.} \item{data_lats}{A numeric vector indicating the latitudes of the data.} @@ -70,7 +69,7 @@ climatology is calculated over the whole period. If the data are already anomalies, set it to FALSE. The default value is NULL.\cr In case of parameter 'type' is 'dcpp', 'indices_for_clim' must be relative to the first forecast year, and the climatology is automatically computed -over the actual common period for the different forecast years.} +over the common calendar period for the different forecast years.} \item{year_dim}{A character string indicating the name of the year dimension The default value is 'year'. Only used if parameter 'type' is 'hist' or @@ -80,25 +79,26 @@ The default value is 'year'. Only used if parameter 'type' is 'hist' or dimension. The default value is 'month'. Only used if parameter 'type' is 'hist' or 'obs'.} -\item{member_dim}{A character string indicating the name of the member -dimension. The default value is 'member'. Only used if parameter 'type' is -'dcpp' or 'hist'.} +\item{na.rm}{A logical value indicanting whether to remove NA values. 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 numerical array of the SPOD index with the dimensions of: - 1) sdate, forecast year, and member (in case of decadal predictions); - 2) year and member (in case of historical simulations); or - 3) year (in case of observations or reanalyses). +A numerical array with the SPOD index with the same dimensions as data except + the lat_dim, lon_dim and fmonth_dim (month_dim) in case of decadal predictions + (historical simulations or observations). In case of decadal predictions, a new dimension + 'fyear' is added. } \description{ The South Pacific Ocean Dipole (SPOD) index is related to the El Nino-Southern Oscillation (ENSO) and the Inderdecadal Pacific Oscillation (IPO). The SPOD index is computed as the difference of weighted-averaged SST anomalies over 20ºS-48ºS, 165ºE-190ºE (NW pole) and the weighted-averaged SST -anomalies over 44ºS-65ºS, 220ºE-260ºE (SE pole) (Saurral et al., 2020). +anomalies over 44ºS-65ºS, 220ºE-260ºE (SE pole) (Saurral et al., 2020). +If different members and/or datasets are provided, the climatology (used to +calculate the anomalies) is computed individually for all of them. } \examples{ ## Observations or reanalyses diff --git a/man/TPI.Rd b/man/TPI.Rd index 3bdc17c..5e8f716 100644 --- a/man/TPI.Rd +++ b/man/TPI.Rd @@ -18,16 +18,15 @@ TPI( indices_for_clim = NULL, year_dim = "year", month_dim = "month", - member_dim = "member", + na.rm = TRUE, ncores = NULL ) } \arguments{ -\item{data}{A numerical array to be used for the index computation with the -dimensions: 1) latitude, longitude, start date, forecast month, and member -(in case of decadal predictions), 2) latitude, longitude, year, month and -member (in case of historical simulations), or 3) latitude, longitude, year -and month (in case of observations or reanalyses). This data has to be +\item{data}{A numerical array to be used for the index computation with, at least, the +dimensions: 1) latitude, longitude, start date and forecast month +(in case of decadal predictions), 2) latitude, longitude, year and month +(in case of historical simulations or observations). This data has to be provided, at least, over the whole region needed to compute the index.} \item{data_lats}{A numeric vector indicating the latitudes of the data.} @@ -70,7 +69,7 @@ climatology is calculated over the whole period. If the data are already anomalies, set it to FALSE. The default value is NULL.\cr In case of parameter 'type' is 'dcpp', 'indices_for_clim' must be relative to the first forecast year, and the climatology is automatically computed -over the actual common period for the different forecast years.} +over the common calendar period for the different forecast years.} \item{year_dim}{A character string indicating the name of the year dimension The default value is 'year'. Only used if parameter 'type' is 'hist' or @@ -80,24 +79,25 @@ The default value is 'year'. Only used if parameter 'type' is 'hist' or dimension. The default value is 'month'. Only used if parameter 'type' is 'hist' or 'obs'.} -\item{member_dim}{A character string indicating the name of the member -dimension. The default value is 'member'. Only used if parameter 'type' is -'dcpp' or 'hist'.} +\item{na.rm}{A logical value indicanting whether to remove NA values. 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 numerical array of the TPI index with the dimensions of: - 1) sdate, forecast year, and member (in case of decadal predictions); - 2) year and member (in case of historical simulations); or - 3) year (in case of observations or reanalyses). +A numerical array with the TPI index with the same dimensions as data except + the lat_dim, lon_dim and fmonth_dim (month_dim) in case of decadal predictions + (historical simulations or observations). In case of decadal predictions, a new dimension + 'fyear' is added. } \description{ The Tripole Index (TPI) for the Interdecadal Pacific Oscillation (IPO) is computed as the difference of weighted-averaged SST anomalies over 10ºS-10ºN, 170ºE-270ºE minus the mean of the weighted-averaged SST anomalies over -25ºN-45ºN, 140ºE-215ºE and 50ºS-15ºS, 150ºE-200ºE (Henley et al., 2015). +25ºN-45ºN, 140ºE-215ºE and 50ºS-15ºS, 150ºE-200ºE (Henley et al., 2015). +If different members and/or datasets are provided, the climatology (used to +calculate the anomalies) is computed individually for all of them. } \examples{ ## Observations or reanalyses -- GitLab From e5bfaaab866d7f7399b2b25f8616fd9c78f6f4b4 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 6 Apr 2021 16:40:55 +0200 Subject: [PATCH 13/28] Revise ProjectField.R to accept 'ano' and 'eof' have different dimensions. --- R/ProjectField.R | 93 +++++++++++++++++++----------- man/ProjectField.Rd | 9 +-- tests/testthat/test-ProjectField.R | 46 ++++++++++----- 3 files changed, 96 insertions(+), 52 deletions(-) diff --git a/R/ProjectField.R b/R/ProjectField.R index 03ad210..3684e23 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -6,10 +6,11 @@ #'and returns NA if the whole spatial pattern is NA. #' #'@param ano A numerical array of anomalies with named dimensions. The -#' dimensions must have at least 'time_dim' and 'space_dim'. -#'@param eof A list contains at least 'EOFs' and 'wght', which are both arrays. -#' 'EOFs' has dimensions same as 'ano' except 'EOFs' has 'mode' and 'ano' has -#' time_dim. 'wght' has dimensions space_dim. It can be generated by EOF(). +#' dimensions must have at least 'time_dim' and 'space_dim'. It can be +#' generated by Ano(). +#'@param eof A list that contains at least 'EOFs' and 'wght', which are both +#' arrays. 'EOFs' must have dimensions 'mode' and 'space_dim' at least. +#' 'wght' has dimensions space_dim. It can be generated by EOF(). #'@param time_dim A character string indicating the name of the time dimension #' of 'ano'. The default value is 'sdate'. #'@param space_dim A vector of two character strings. The first is the dimension @@ -55,11 +56,13 @@ #'} #' #'@export -ProjectField <- function(ano, eof, time_dim = 'sdate', - space_dim = c('lat', 'lon'), mode = 1, ncores = NULL) { +ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon'), + mode = 1, ncores = NULL) { + +#oh ok. So the rule of input 'eof' dim is to have [mode, lat, lon] at least. And for input 'ano' dim is [sdate, lat, lon] at least. Is it correct? # Check inputs - ## ano + ## ano (1) if (is.null(ano)) { stop("Parameter 'ano' cannot be NULL.") } @@ -99,32 +102,17 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', if (any(!space_dim %in% names(dim(ano)))) { stop("Parameter 'space_dim' is not found in 'ano' dimension.") } + ## ano (2) + if (!all(space_dim %in% names(dim(ano))) | !time_dim %in% names(dim(ano))) { + stop(paste0("Parameter 'ano' must be an array with dimensions named as ", + "parameter 'space_dim' and 'time_dim'.")) + } ## eof (2) if (!all(space_dim %in% names(dim(eof$EOFs))) | !'mode' %in% names(dim(eof$EOFs))) { stop(paste0("The component 'EOFs' of parameter 'eof' must be an array ", "with dimensions named as parameter 'space_dim' and 'mode'.")) } - # eof$EOFs should have the same dimensions as 'ano' except that ano doesn't have 'mode' and EOFs doesn't have time_dim - common_dim_ano <- dim(ano)[-which(names(dim(ano)) == time_dim)] - common_dim_eofs <- dim(eof$EOFs)[-which(names(dim(eof$EOFs)) == 'mode')] - raise_error <- FALSE - if (length(common_dim_ano) != length(common_dim_eofs)) { - raise_error <- TRUE - } else if (!all(names(common_dim_ano) %in% names(common_dim_eofs)) | - !all(names(common_dim_eofs) %in% names(common_dim_ano))) { - raise_error <- TRUE - } else { - order <- match(names(common_dim_ano), names(common_dim_eofs)) - if (any(common_dim_eofs[order] != common_dim_ano)) { - raise_error <- TRUE - } - } - if (raise_error) { - stop(paste0("The component 'EOFs' of parameter 'eof' must have the ", - "same dimensions as 'ano' except that 'ano' does not have ", - "'mode' and 'EOFs' does not have time_dim.")) - } if (length(dim(eof$wght)) != 2 | !all(names(dim(eof$wght)) %in% space_dim)) { stop(paste0("The component 'wght' of parameter 'eof' must be an array ", "with dimensions named as parameter 'space_dim'.")) @@ -150,13 +138,47 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', # Keep the chosen mode eof_mode <- Subset(eof$EOFs, 'mode', mode, drop = 'selected') - res <- Apply(list(ano, eof_mode, eof$wght), - target_dims = list(c(space_dim, time_dim), - c(space_dim), - c(space_dim)), - output_dims = time_dim, - fun = .ProjectField, - ncores = ncores)$output1 + if (all(names(dim(eof_mode)) %in% space_dim)) { # eof_mode: [lat, lon] + + res <- Apply(list(ano), + target_dims = list(c(space_dim, time_dim)), + output_dims = time_dim, + eof_mode = eof_mode, + wght = eof$wght, + fun = .ProjectField, + ncores = ncores)$output1 + + } else { + if (!all(names(dim(eof_mode)) %in% names(dim(ano)))) { + stop(paste0("The array 'EOF' in parameter 'eof' has dimension not in parameter ", + "'ano'. Check if 'ano' and 'eof' are compatible.")) + } + + common_dim_ano <- dim(ano)[which(names(dim(ano)) %in% names(dim(eof_mode)))] + if (any(sort(common_dim_ano) != sort(dim(eof_mode)))) { + stop(paste0("Found paramter 'ano' and 'EOF' in parameter 'eof' have different ", + "common dimensions. Check if 'ano' and 'eof' are compatible.")) + } + + # Enlarge eof/ano is needed. The margin_dims of Apply() must be consistent + # between ano and eof. + additional_dims <- dim(ano)[-which(names(dim(ano)) %in% names(dim(eof_mode)))] + additional_dims <- additional_dims[-which(names(additional_dims) == time_dim)] + if (length(additional_dims) != 0) { + for (i in 1:length(additional_dims)) { + eof_mode <- InsertDim(eof_mode, posdim = (length(dim(eof_mode)) + 1), + lendim = additional_dims[i], name = names(additional_dims)[i]) + } + } + + res <- Apply(list(ano, eof_mode), + target_dims = list(c(space_dim, time_dim), + c(space_dim)), + output_dims = time_dim, + wght = eof$wght, + fun = .ProjectField, + ncores = ncores)$output1 + } return(res) } @@ -166,6 +188,7 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', # ano: [lat, lon, sdate] # eof_mode: [lat, lon] # wght: [lat, lon] + dim_time <- dim(ano)[3] # Initialization of pc.ver. @@ -173,8 +196,8 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', # Weigths e.1 <- eof_mode * wght - ano <- ano * InsertDim(wght, 3, dim_time) + na <- apply(ano, 3, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA tmp <- ano * InsertDim(e.1, 3, dim_time) # [lat, lon, sdate] pc.ver <- apply(tmp, 3, sum, na.rm = TRUE) diff --git a/man/ProjectField.Rd b/man/ProjectField.Rd index d2bd9fb..97353ff 100644 --- a/man/ProjectField.Rd +++ b/man/ProjectField.Rd @@ -15,11 +15,12 @@ ProjectField( } \arguments{ \item{ano}{A numerical array of anomalies with named dimensions. The -dimensions must have at least 'time_dim' and 'space_dim'.} +dimensions must have at least 'time_dim' and 'space_dim'. It can be +generated by Ano().} -\item{eof}{A list contains at least 'EOFs' and 'wght', which are both arrays. -'EOFs' has dimensions same as 'ano' except 'EOFs' has 'mode' and 'ano' has - time_dim. 'wght' has dimensions space_dim. It can be generated by EOF().} +\item{eof}{A list that contains at least 'EOFs' and 'wght', which are both +arrays. 'EOFs' must have dimensions 'mode' and 'space_dim' at least. +'wght' has dimensions space_dim. It can be generated by EOF().} \item{time_dim}{A character string indicating the name of the time dimension of 'ano'. The default value is 'sdate'.} diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R index c306a7a..3cf14d2 100644 --- a/tests/testthat/test-ProjectField.R +++ b/tests/testthat/test-ProjectField.R @@ -25,10 +25,21 @@ context("s2dv::ProjectField tests") # dat4 set.seed(1) - dat4 <- array(rnorm(288), dim = c(dat = 1, memb = 2, sdate = 6, ftime = 3, lat = 4, lon = 2)) + dat4 <- array(rnorm(288*2), dim = c(dat = 2, memb = 2, sdate = 6, ftime = 3, lat = 4, lon = 2)) lat4 <- seq(-10, -30, length.out = 4) lon4 <- c(350, 355) - eof4 <- EOF(dat4, lat4, lon4) + set.seed(2) + tmp <- array(rnorm(144), dim = c(dat = 2, sdate = 6, lat = 4, lon = 2)) + eof4 <- EOF(tmp, lat4, lon4) + + # dat5 + set.seed(1) + dat5 <- array(rnorm(144*3), dim = c(dat = 1, memb = 2, sdate = 6, ftime = 3, lat = 4, lon = 3)) + lat5 <- seq(-10, 10, length.out = 4) + lon5 <- c(0, 5, 10) + set.seed(2) + tmp <- array(rnorm(72), dim = c(sdate = 6, lat = 4, lon = 3)) + eof5 <- EOF(tmp, lat5, lon5) ############################################## test_that("1. Input checks", { @@ -100,14 +111,6 @@ test_that("1. Input checks", { paste0("The component 'EOFs' of parameter 'eof' must be an array ", "with dimensions named as parameter 'space_dim' and 'mode'.") ) - eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 6, lon = 3)), - wght = array(rnorm(10), dim = c(lat = 6, lon = 2))) - expect_error( - ProjectField(dat1, eof_fake), - paste0("The component 'EOFs' of parameter 'eof' must have the ", - "same dimensions as 'ano' except that 'ano' does not have ", - "'mode' and 'EOFs' does not have time_dim.") - ) eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 6, lon = 2)), wght = array(rnorm(10), dim = c(level = 6, lon = 2))) expect_error( @@ -187,18 +190,35 @@ test_that("4. dat3", { test_that("5. dat4", { expect_equal( dim(ProjectField(dat4, eof4)), - c(sdate = 6, dat = 1, memb = 2, ftime = 3) + c(sdate = 6, dat = 2, memb = 2, ftime = 3) ) expect_equal( mean(ProjectField(dat4, eof4)), - -0.1179755, + 0.078082, tolerance = 0.0001 ) expect_equal( ProjectField(dat4, eof4)[, 1, 2, 2], - c(1.73869255, -2.58156427, 0.05340228, -0.53610350, -3.13985059, 1.58785066), + c(0.28137048, -0.17616154, -0.39155370, 0.08288953, 1.18465521, 0.81850535), tolerance = 0.0001 ) }) ############################################## +test_that("6. dat5", { + expect_equal( + dim(ProjectField(dat5, eof5)), + c(sdate = 6, dat = 1, memb = 2, ftime = 3) + ) + expect_equal( + mean(ProjectField(dat5, eof5)), + 0.0907149, + tolerance = 0.0001 + ) + expect_equal( + ProjectField(dat5, eof5)[, 1, 2, 2], + c(0.60881970, 0.93588392, 0.01982465, 0.82376024, -0.33147699, -1.35488289), + tolerance = 0.0001 + ) + +}) -- GitLab From 34ba71016756478d5e4c6a2264cbd9601bd1ad28 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 6 Apr 2021 19:35:01 +0200 Subject: [PATCH 14/28] Remove comment. --- R/ProjectField.R | 2 -- 1 file changed, 2 deletions(-) diff --git a/R/ProjectField.R b/R/ProjectField.R index 3684e23..aa30a40 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -59,8 +59,6 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon'), mode = 1, ncores = NULL) { -#oh ok. So the rule of input 'eof' dim is to have [mode, lat, lon] at least. And for input 'ano' dim is [sdate, lat, lon] at least. Is it correct? - # Check inputs ## ano (1) if (is.null(ano)) { -- GitLab From 8313fc08abdd459a7b5eaf791444a9bcd432ee28 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 12 Apr 2021 10:17:58 +0200 Subject: [PATCH 15/28] Add @import multiApply --- R/ProjectField.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/ProjectField.R b/R/ProjectField.R index aa30a40..2e9d26f 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -55,6 +55,7 @@ #' } #'} #' +#'@import multiApply #'@export ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon'), mode = 1, ncores = NULL) { -- GitLab From eb325ec1a76e5ba3230a1cf952afb817550676f9 Mon Sep 17 00:00:00 2001 From: aho Date: Wed, 28 Apr 2021 17:32:25 +0200 Subject: [PATCH 16/28] Fix documentation --- R/Ano_CrossValid.R | 2 +- man/Ano_CrossValid.Rd | 3 ++- tests/testthat/test-Ano_CrossValid.R | 2 +- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/R/Ano_CrossValid.R b/R/Ano_CrossValid.R index f625ccc..22e710a 100644 --- a/R/Ano_CrossValid.R +++ b/R/Ano_CrossValid.R @@ -25,7 +25,7 @@ #' in 'dat_dim'. The default value is 'member'. #'@param memb A logical value indicating whether to subtract the climatology #' based on the individual members (TRUE) or the ensemble mean over all -# members (FALSE) when calculating the anomalies. The default value is TRUE. +#' members (FALSE) when calculating the anomalies. The default value is TRUE. #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' diff --git a/man/Ano_CrossValid.Rd b/man/Ano_CrossValid.Rd index 3fe1e60..1e91528 100644 --- a/man/Ano_CrossValid.Rd +++ b/man/Ano_CrossValid.Rd @@ -35,7 +35,8 @@ 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 subtract the climatology -based on the individual members (TRUE) or the ensemble mean over all} +based on the individual members (TRUE) or the ensemble mean over all +members (FALSE) when calculating the anomalies. The default value is TRUE.} \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} diff --git a/tests/testthat/test-Ano_CrossValid.R b/tests/testthat/test-Ano_CrossValid.R index 52dcf73..60bff8c 100644 --- a/tests/testthat/test-Ano_CrossValid.R +++ b/tests/testthat/test-Ano_CrossValid.R @@ -1,4 +1,4 @@ -context("s2dv::EOF tests") +context("s2dv::Ano_CrossValid tests") ############################################## # dat1 -- GitLab From 635ea2042e7b265a2301ddbfe5ce54b0ffad209c Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 29 Apr 2021 14:48:17 +0200 Subject: [PATCH 17/28] Add output 'tot_var' in EOF --- R/EOF.R | 27 ++++++++++++++++----------- man/EOF.Rd | 24 ++++++++++++++---------- tests/testthat/test-EOF.R | 14 ++++++++++++-- 3 files changed, 42 insertions(+), 23 deletions(-) diff --git a/R/EOF.R b/R/EOF.R index f37fa8f..d573739 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -25,27 +25,27 @@ #'A list containing: #'\item{EOFs}{ #' An array of EOF patterns normalized to 1 (unitless) with dimensions -#' (number of modes, rest of the dimensions of ano except 'time_dim'). +#' (number of modes, rest of the dimensions of 'ano' except 'time_dim'). #' Multiplying \code{EOFs} by \code{PCs} gives the original reconstructed #' field. #'} #'\item{PCs}{ #' An array of principal components with the units of the original field to #' the power of 2, with dimensions (time_dim, number of modes, rest of the -#' dimensions except 'space_dim'). -#' \code{PCs} contains already the percentage of explained variance so, -#' to reconstruct the original field it's only needed to multiply \code{EOFs} -#' by \code{PCs}. +#' dimensions of 'ano' except 'space_dim'). +#' 'PCs' contains already the percentage of explained variance so, +#' to reconstruct the original field it's only needed to multiply 'EOFs' +#' by 'PCs'. #'} #'\item{var}{ #' An array of the percentage (%) of variance fraction of total variance #' explained by each mode (number of modes). The dimensions are (number of -#' modes, rest of the dimension except 'time_dim' and 'space_dim'). +#' modes, rest of the dimensions of 'ano' except 'time_dim' and 'space_dim'). #'} #'\item{mask}{ -#' An array of the mask with dimensions (space_dim, rest of the dimension -#' except 'time_dim'). It is made from 'ano', 1 for the positions that 'ano' -#' has value and NA for the positions that 'ano' has NA. It is used to +#' An array of the mask with dimensions (space_dim, rest of the dimensions of +#' 'ano' except 'time_dim'). It is made from 'ano', 1 for the positions that +#' 'ano' has value and NA for the positions that 'ano' has NA. It is used to #' replace NAs with 0s for EOF calculation and mask the result with NAs again #' after the calculation. #'} @@ -54,6 +54,10 @@ #' by cosine of 'lat' and used to compute the fraction of variance explained by #' each EOFs. #'} +#'\item{tot_var}{ +#' A number or a numeric array of the total variance explained by all the modes. +#' The dimensions are same as 'ano' except 'time_dim' and 'space_dim'. +#'} #' #'@seealso ProjectField, NAO, PlotBoxWhisker #'@examples @@ -73,7 +77,7 @@ #'} #'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) #'tmp <- MeanDims(ano$exp, c('dataset', 'member')) -#'ano <- tmp[, 1, ,] +#'ano <- tmp[1, , ,] #'names(dim(ano)) <- names(dim(tmp))[-2] #'eof <- EOF(ano, sampleData$lat, sampleData$lon) #'\dontrun{ @@ -163,6 +167,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), output_dims = list(EOFs = c('mode', space_dim), PCs = c(time_dim, 'mode'), var = 'mode', + tot_var = NULL, mask = space_dim), fun = .EOF, corr = corr, neofs = neofs, @@ -274,5 +279,5 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), var.eof <- as.array(var.eof) } - return(list(EOFs = EOF, PCs = PC, var = var.eof, mask = mask)) + return(invisible(list(EOFs = EOF, PCs = PC, var = var.eof, tot_var = tot.var, mask = mask))) } diff --git a/man/EOF.Rd b/man/EOF.Rd index b460cd5..a7d51a7 100644 --- a/man/EOF.Rd +++ b/man/EOF.Rd @@ -44,27 +44,27 @@ computation. The default value is NULL.} A list containing: \item{EOFs}{ An array of EOF patterns normalized to 1 (unitless) with dimensions - (number of modes, rest of the dimensions of ano except 'time_dim'). + (number of modes, rest of the dimensions of 'ano' except 'time_dim'). Multiplying \code{EOFs} by \code{PCs} gives the original reconstructed field. } \item{PCs}{ An array of principal components with the units of the original field to the power of 2, with dimensions (time_dim, number of modes, rest of the - dimensions except 'space_dim'). - \code{PCs} contains already the percentage of explained variance so, - to reconstruct the original field it's only needed to multiply \code{EOFs} - by \code{PCs}. + dimensions of 'ano' except 'space_dim'). + 'PCs' contains already the percentage of explained variance so, + to reconstruct the original field it's only needed to multiply 'EOFs' + by 'PCs'. } \item{var}{ An array of the percentage (%) of variance fraction of total variance explained by each mode (number of modes). The dimensions are (number of - modes, rest of the dimension except 'time_dim' and 'space_dim'). + modes, rest of the dimensions of 'ano' except 'time_dim' and 'space_dim'). } \item{mask}{ - An array of the mask with dimensions (space_dim, rest of the dimension - except 'time_dim'). It is made from 'ano', 1 for the positions that 'ano' - has value and NA for the positions that 'ano' has NA. It is used to + An array of the mask with dimensions (space_dim, rest of the dimensions of + 'ano' except 'time_dim'). It is made from 'ano', 1 for the positions that + 'ano' has value and NA for the positions that 'ano' has NA. It is used to replace NAs with 0s for EOF calculation and mask the result with NAs again after the calculation. } @@ -73,6 +73,10 @@ A list containing: by cosine of 'lat' and used to compute the fraction of variance explained by each EOFs. } +\item{tot_var}{ + A number or a numeric array of the total variance explained by all the modes. + The dimensions are same as 'ano' except 'time_dim' and 'space_dim'. +} } \description{ Perform an area-weighted EOF analysis using SVD based on a covariance matrix @@ -96,7 +100,7 @@ sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), } ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) tmp <- MeanDims(ano$exp, c('dataset', 'member')) -ano <- tmp[, 1, ,] +ano <- tmp[1, , ,] names(dim(ano)) <- names(dim(tmp))[-2] eof <- EOF(ano, sampleData$lat, sampleData$lon) \dontrun{ diff --git a/tests/testthat/test-EOF.R b/tests/testthat/test-EOF.R index e15a971..c8c6d30 100644 --- a/tests/testthat/test-EOF.R +++ b/tests/testthat/test-EOF.R @@ -99,7 +99,7 @@ test_that("2. dat1", { expect_equal( names(EOF(dat1, lon = lon1, lat = lat1)), - c("EOFs", "PCs", "var", "mask", "wght") + c("EOFs", "PCs", "var", "tot_var", "mask", "wght") ) expect_equal( dim(EOF(dat1, lon = lon1, lat = lat1)$EOFs), @@ -143,7 +143,7 @@ test_that("2. dat1", { ) expect_equal( EOF(dat1, lon = lon1, lat = lat1)$var[1:5], - array(c(29.247073, 25.364840, 13.247046, 11.121006, 8.662517)), + array(c(29.247073, 25.364840, 13.247046, 11.121006, 8.662517), dim = c(mode = 5)), tolerance = 0.0001 ) expect_equal( @@ -155,6 +155,11 @@ test_that("2. dat1", { c(0.9923748, 0.9850359, 0.9752213, 0.9629039, 0.9480475), tolerance = 0.0001 ) + expect_equal( + EOF(dat1, lon = lon1, lat = lat1)$tot_var, + 88.20996, + tolerance = 0.0001 + ) }) ############################################## @@ -212,6 +217,11 @@ test_that("4. dat3", { c(0.3292733, 0.1787016, -0.3801986, 0.1957160, -0.4377031), tolerance = 0.0001 ) + expect_equal( + EOF(dat3, lon = lon3, lat = lat3)$tot_var, + array(c(213.2422, 224.4203), dim = c(dat = 2)), + tolerance = 0.0001 + ) }) ############################################## -- GitLab From afc2ebde52bf1d389966f32ffe34bb4f6bc4d583 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 29 Apr 2021 17:27:17 +0200 Subject: [PATCH 18/28] Add warning when 'neofs' is changed. --- R/EOF.R | 17 ++++++++++++----- man/EOF.Rd | 4 ++-- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/R/EOF.R b/R/EOF.R index d573739..8375eec 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -14,8 +14,8 @@ #' name of latitude of 'ano' and the second is the dimension name of longitude #' of 'ano'. The default value is c('lat', 'lon'). #'@param neofs An integer of the modes to be kept. The default value is 15. -#' If time length or the product of latitude length and longitude length is -#' less than neofs, neofs is equal to the minimum of the three values. +#' If time length or the product of the length of space_dim is smaller than +#' neofs, neofs will be changed to the minimum of the three values. #'@param corr A logical value indicating whether to base on a correlation (TRUE) #' or on a covariance matrix (FALSE). The default value is FALSE. #'@param ncores An integer indicating the number of cores to use for parallel @@ -147,6 +147,8 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), } } + ############################### + # Calculate EOF # # Replace mask of NAs with 0s for EOF analysis. # ano[!is.finite(ano)] <- 0 @@ -162,6 +164,14 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), # times ano. wght <- sqrt(wght) + # neofs is bounded + if (neofs != min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), neofs)) { + neofs <- min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), neofs) + .warning(paste0("Parameter 'neofs' is changed to ", neofs, ", the minimum among ", + "the length of time_dim, the production of the length of space_dim, ", + "and neofs.")) + } + res <- Apply(ano, target_dims = c(time_dim, space_dim), output_dims = list(EOFs = c('mode', space_dim), @@ -222,9 +232,6 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), pca <- La.svd(ano) } - # neofs is bounded - neofs <- min(dim.dat, neofs) - # La.svd conventions: decomposition X = U D t(V) La.svd$u # returns U La.svd$d returns diagonal values of D La.svd$v # returns t(V) !! The usual convention is PC=U and EOF=V. diff --git a/man/EOF.Rd b/man/EOF.Rd index a7d51a7..dc40658 100644 --- a/man/EOF.Rd +++ b/man/EOF.Rd @@ -31,8 +31,8 @@ name of latitude of 'ano' and the second is the dimension name of longitude of 'ano'. The default value is c('lat', 'lon').} \item{neofs}{An integer of the modes to be kept. The default value is 15. -If time length or the product of latitude length and longitude length is -less than neofs, neofs is equal to the minimum of the three values.} +If time length or the product of the length of space_dim is smaller than +neofs, neofs will be changed to the minimum of the three values.} \item{corr}{A logical value indicating whether to base on a correlation (TRUE) or on a covariance matrix (FALSE). The default value is FALSE.} -- GitLab From 2e103ed43c2dc0c8cabefe014503c644844d410d Mon Sep 17 00:00:00 2001 From: aho Date: Fri, 30 Apr 2021 14:15:32 +0200 Subject: [PATCH 19/28] Add new function REOF. Improve EOF documentation --- NAMESPACE | 1 + R/EOF.R | 12 +- R/REOF.R | 217 +++++++++++++++++++++++++++++++++++++ man/EOF.Rd | 10 +- man/REOF.Rd | 99 +++++++++++++++++ tests/testthat/test-REOF.R | 168 ++++++++++++++++++++++++++++ 6 files changed, 496 insertions(+), 11 deletions(-) create mode 100644 R/REOF.R create mode 100644 man/REOF.Rd create mode 100644 tests/testthat/test-REOF.R diff --git a/NAMESPACE b/NAMESPACE index 3e14c43..75ded15 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -44,6 +44,7 @@ export(PlotMatrix) export(PlotSection) export(PlotStereoMap) export(ProjectField) +export(REOF) export(RMS) export(RMSSS) export(RandomWalkTest) diff --git a/R/EOF.R b/R/EOF.R index 8375eec..4221ccf 100644 --- a/R/EOF.R +++ b/R/EOF.R @@ -1,8 +1,8 @@ #'Area-weighted empirical orthogonal function analysis using SVD #' -#'Perform an area-weighted EOF analysis using SVD based on a covariance matrix -#'by default, based on the correlation matrix if \code{corr} argument is set to -#'\code{TRUE}. +#'Perform an area-weighted EOF analysis using single value decomposition (SVD) +#'based on a covariance matrix or a correlation matrix if parameter 'corr' is +#'set to TRUE. #' #'@param ano A numerical array of anomalies with named dimensions to calculate #' EOF. The dimensions must have at least 'time_dim' and 'space_dim'. @@ -13,8 +13,8 @@ #'@param space_dim A vector of two character strings. The first is the dimension #' name of latitude of 'ano' and the second is the dimension name of longitude #' of 'ano'. The default value is c('lat', 'lon'). -#'@param neofs An integer of the modes to be kept. The default value is 15. -#' If time length or the product of the length of space_dim is smaller than +#'@param neofs A positive integer of the modes to be kept. The default value is +#' 15. If time length or the product of the length of space_dim is smaller than #' neofs, neofs will be changed to the minimum of the three values. #'@param corr A logical value indicating whether to base on a correlation (TRUE) #' or on a covariance matrix (FALSE). The default value is FALSE. @@ -132,7 +132,7 @@ EOF <- function(ano, lat, lon, time_dim = 'sdate', space_dim = c('lat', 'lon'), warning("Some 'lon' is out of the range [-360, 360].") } ## neofs - if (!is.numeric(neofs) | neofs %% 1 != 0 | neofs < 0 | length(neofs) > 1) { + if (!is.numeric(neofs) | neofs %% 1 != 0 | neofs <= 0 | length(neofs) > 1) { stop("Parameter 'neofs' must be a positive integer.") } ## corr diff --git a/R/REOF.R b/R/REOF.R new file mode 100644 index 0000000..30ef6f0 --- /dev/null +++ b/R/REOF.R @@ -0,0 +1,217 @@ +#'Area-weighted empirical orthogonal function analysis with varimax rotation using SVD +#' +#'Perform an area-weighted EOF analysis with varimax rotation using single +#'value decomposition (SVD) based on a covariance matrix or a correlation matrix if +#'parameter 'corr' is set to TRUE. The internal s2dv function \code{.EOF()} is used +#'internally. +#' +#'@param ano A numerical array of anomalies with named dimensions to calculate +#' REOF. The dimensions must have at least 'time_dim' and 'space_dim'. +#'@param lat A vector of the latitudes of 'ano'. +#'@param lon A vector of the longitudes of 'ano'. +#'@param time_dim A character string indicating the name of the time dimension +#' of 'ano'. The default value is 'sdate'. +#'@param space_dim A vector of two character strings. The first is the dimension +#' name of longitude of 'ano' and the second is the dimension name of latitude +#' of 'ano'. The default value is c('lon', 'lat'). +#'@param ntrunc A positive integer of the modes to be kept. The default value +#' is 15. If time length or the product of latitude length and longitude +#' length is less than ntrunc, ntrunc is equal to the minimum of the three +#' values. +#'@param corr A logical value indicating whether to base on a correlation (TRUE) +#' or on a covariance matrix (FALSE). The default value is FALSE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list containing: +#'\item{REOFs}{ +#' An array of REOF patterns normalized to 1 (unitless) with dimensions +#' (number of modes, rest of the dimensions of ano except 'time_dim'). +#' Multiplying 'REOFs' by 'RPCs' gives the original reconstructed +#' field. +#'} +#'\item{RPCs}{ +#' An array of principal components with the units of the original field to +#' the power of 2, with dimensions (time_dim, number of modes, rest of the +#' dimensions except 'space_dim'). +#'} +#'\item{var}{ +#' An array of the percentage (%) of variance fraction of total variance +#' explained by each mode. The dimensions are (number of modes, rest of the +#' dimension except 'time_dim' and 'space_dim'). +#'} +#'\item{wght}{ +#' An array of the area weighting with dimensions 'space_dim'. It is calculated +#' by cosine of 'lat' and used to compute the fraction of variance explained by +#' each REOFs. +#'} +#' +#'@seealso EOF +#'@examples +#'# This example computes the REOFs along forecast horizons and plots the one +#'# that explains the greatest amount of variability. The example data has low +#'# resolution so the result may not be explanatory, but it displays how to +#'# use this function. +#'\dontshow{ +#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +#'sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), +#' c('observation'), startDates, +#' leadtimemin = 1, +#' leadtimemax = 4, +#' output = 'lonlat', +#' latmin = 27, latmax = 48, +#' lonmin = -12, lonmax = 40) +#'} +#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +#'ano <- MeanDims(ano$exp, c('dataset', 'member')) +#'res <- REOF(ano, lat = sampleData$lat, lon = sampleData$lon, ntrunc = 5) +#'\dontrun{ +#'PlotEquiMap(eof$EOFs[1, , , 1], sampleData$lat, sampleData$lon) +#'} +#' +#'@import multiApply +#'@export +REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', + space_dim = c('lat', 'lon'), corr = FALSE, ncores = NULL) { + + # Check inputs + ## ano + if (is.null(ano)) { + stop("Parameter 'ano' cannot be NULL.") + } + if (!is.numeric(ano)) { + stop("Parameter 'ano' must be a numeric array.") + } + if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + stop("Parameter 'ano' 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(ano))) { + stop("Parameter 'time_dim' is not found in 'ano' dimension.") + } + ## space_dim + if (!is.character(space_dim) | length(space_dim) != 2) { + stop("Parameter 'space_dim' must be a character vector of 2.") + } + if (any(!space_dim %in% names(dim(ano)))) { + stop("Parameter 'space_dim' is not found in 'ano' dimension.") + } + ## lat + if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { + stop(paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.")) + } + if (any(lat > 90 | lat < -90)) { + stop("Parameter 'lat' must contain values within the range [-90, 90].") + } + ## lon + if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { + stop(paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.")) + } + if (any(lon > 360 | lon < -360)) { + warning("Some 'lon' is out of the range [-360, 360].") + } + ## ntrunc + if (!is.numeric(ntrunc) | ntrunc %% 1 != 0 | ntrunc <= 0 | length(ntrunc) > 1) { + stop("Parameter 'ntrunc' must be a positive integer.") + } + ## corr + if (!is.logical(corr) | length(corr) > 1) { + stop("Parameter 'corr' 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 REOF + + # ntrunc is bounded + if (ntrunc != min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), ntrunc)) { + ntrunc <- min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), ntrunc) + .warning(paste0("Parameter 'ntrunc' is changed to ", ntrunc, ", the minimum among ", + "the length of time_dim, the production of the length of space_dim, ", + "and ntrunc.")) + } + + # Area weighting is needed to compute the fraction of variance explained by + # each mode + space_ind <- sapply(space_dim, function(a) which(names(dim(ano)) == a)) + wght <- array(cos(lat * pi/180), dim = dim(ano)[space_ind]) + + # We want the covariance matrix to be weigthed by the grid + # cell area so the anomaly field is weighted by its square + # root since the covariance matrix equals transpose(ano) + # times ano. + wght <- sqrt(wght) + + res <- Apply(ano, + target_dims = c(time_dim, space_dim), + output_dims = list(REOFs = c('mode', space_dim), + RPCs = c(time_dim, 'mode'), + var = 'mode', + wght = space_dim), + fun = .REOF, + corr = corr, ntrunc = ntrunc, wght = wght, + ncores = ncores) + + return(res) + +} + + +.REOF <- function(ano, ntrunc, corr = FALSE, wght = wght) { + # ano: [sdate, lat, lon] + + # Dimensions + nt <- dim(ano)[1] + ny <- dim(ano)[2] + nx <- dim(ano)[3] + + # Get the first ntrunc EOFs: + eofs <- .EOF(ano = ano, neofs = ntrunc, corr = corr, wght = wght) #list(EOFs = EOF, PCs = PC, var = var.eof, mask = mask) + + # Recover loadings (with norm 1), weight the EOFs by the weigths + # eofs$EOFs: [mode, lat, lon] + Loadings <- apply(eofs$EOFs, 1, '*', wght) # [lat*lon, mode] + + # Rotate the loadings: + varim <- varimax(Loadings) + + # Weight back the rotated loadings (REOFs): + if (is.list(varim)) { + varim_loadings <- varim$loadings # [lat*lon, mode] + } else { # if mode = 1, varim is an array + varim_loadings <- varim + } + REOFs <- apply(varim_loadings, 2, '/', wght) + dim(REOFs) <- c(ny, nx, ntrunc) + + # Reorder dimensions to match EOF conventions: [mode, lat, lon] + REOFs <- aperm(REOFs, c(3, 1, 2)) + + # Compute the rotated PCs (RPCs): multiply the weigthed anomalies by the loading patterns. + ano.wght <- apply(ano, 1, '*', wght) # [lat*lon, sdate] + RPCs <- t(ano.wght) %*% varim_loadings # [sdate, mode] + + ## Alternative methods suggested here: + ## https://stats.stackexchange.com/questions/59213/how-to-compute-varimax-rotated-principal-components-in-r/137003#137003 + ## gives same results as pinv is just transpose in this case, as loadings are ortonormal! + # invLoadings <- t(pracma::pinv(varim$loadings)) ## invert and traspose the rotated loadings. pinv uses a SVD again (!) + # RPCs <- ano.wght %*% invLoadings + + # Compute explained variance fraction: + var <- apply(RPCs, 2, function(x) { sum(x*x) } ) * 100 / eofs$tot_var # [mode] + dim(var) <- c(mode = length(var)) + + return(invisible(list(REOFs = REOFs, RPCs = RPCs, var = var, wght = wght))) +} diff --git a/man/EOF.Rd b/man/EOF.Rd index dc40658..ae84c55 100644 --- a/man/EOF.Rd +++ b/man/EOF.Rd @@ -30,8 +30,8 @@ of 'ano'. The default value is 'sdate'.} name of latitude of 'ano' and the second is the dimension name of longitude of 'ano'. The default value is c('lat', 'lon').} -\item{neofs}{An integer of the modes to be kept. The default value is 15. -If time length or the product of the length of space_dim is smaller than +\item{neofs}{A positive integer of the modes to be kept. The default value is +15. If time length or the product of the length of space_dim is smaller than neofs, neofs will be changed to the minimum of the three values.} \item{corr}{A logical value indicating whether to base on a correlation (TRUE) @@ -79,9 +79,9 @@ A list containing: } } \description{ -Perform an area-weighted EOF analysis using SVD based on a covariance matrix -by default, based on the correlation matrix if \code{corr} argument is set to -\code{TRUE}. +Perform an area-weighted EOF analysis using single value decomposition (SVD) +based on a covariance matrix or a correlation matrix if parameter 'corr' is +set to TRUE. } \examples{ # This example computes the EOFs along forecast horizons and plots the one diff --git a/man/REOF.Rd b/man/REOF.Rd new file mode 100644 index 0000000..a65331c --- /dev/null +++ b/man/REOF.Rd @@ -0,0 +1,99 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/REOF.R +\name{REOF} +\alias{REOF} +\title{Area-weighted empirical orthogonal function analysis with varimax rotation using SVD} +\usage{ +REOF( + ano, + lat, + lon, + ntrunc = 15, + time_dim = "sdate", + space_dim = c("lat", "lon"), + corr = FALSE, + ncores = NULL +) +} +\arguments{ +\item{ano}{A numerical array of anomalies with named dimensions to calculate +REOF. The dimensions must have at least 'time_dim' and 'space_dim'.} + +\item{lat}{A vector of the latitudes of 'ano'.} + +\item{lon}{A vector of the longitudes of 'ano'.} + +\item{ntrunc}{A positive integer of the modes to be kept. The default value +is 15. If time length or the product of latitude length and longitude +length is less than ntrunc, ntrunc is equal to the minimum of the three +values.} + +\item{time_dim}{A character string indicating the name of the time dimension +of 'ano'. The default value is 'sdate'.} + +\item{space_dim}{A vector of two character strings. The first is the dimension +name of longitude of 'ano' and the second is the dimension name of latitude +of 'ano'. The default value is c('lon', 'lat').} + +\item{corr}{A logical value indicating whether to base on a correlation (TRUE) +or on a covariance matrix (FALSE). The default value is FALSE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list containing: +\item{REOFs}{ + An array of REOF patterns normalized to 1 (unitless) with dimensions + (number of modes, rest of the dimensions of ano except 'time_dim'). + Multiplying 'REOFs' by 'RPCs' gives the original reconstructed + field. +} +\item{RPCs}{ + An array of principal components with the units of the original field to + the power of 2, with dimensions (time_dim, number of modes, rest of the + dimensions except 'space_dim'). +} +\item{var}{ + An array of the percentage (%) of variance fraction of total variance + explained by each mode. The dimensions are (number of modes, rest of the + dimension except 'time_dim' and 'space_dim'). +} +\item{wght}{ + An array of the area weighting with dimensions 'space_dim'. It is calculated + by cosine of 'lat' and used to compute the fraction of variance explained by + each REOFs. +} +} +\description{ +Perform an area-weighted EOF analysis with varimax rotation using single +value decomposition (SVD) based on a covariance matrix or a correlation matrix if +parameter 'corr' is set to TRUE. The internal s2dv function \code{.EOF()} is used +internally. +} +\examples{ +# This example computes the REOFs along forecast horizons and plots the one +# that explains the greatest amount of variability. The example data has low +# resolution so the result may not be explanatory, but it displays how to +# use this function. +\dontshow{ +startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') +sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), + c('observation'), startDates, + leadtimemin = 1, + leadtimemax = 4, + output = 'lonlat', + latmin = 27, latmax = 48, + lonmin = -12, lonmax = 40) +} +ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) +ano <- MeanDims(ano$exp, c('dataset', 'member')) +res <- REOF(ano, lat = sampleData$lat, lon = sampleData$lon, ntrunc = 5) +\dontrun{ +PlotEquiMap(eof$EOFs[1, , , 1], sampleData$lat, sampleData$lon) +} + +} +\seealso{ +EOF +} diff --git a/tests/testthat/test-REOF.R b/tests/testthat/test-REOF.R new file mode 100644 index 0000000..296e57a --- /dev/null +++ b/tests/testthat/test-REOF.R @@ -0,0 +1,168 @@ +context("s2dv::REOF tests") + +############################################## + # dat1 + set.seed(1) + dat1 <- array(rnorm(120), dim = c(sdate = 10, lat = 6, lon = 2)) + lat1 <- seq(10, 30, length.out = 6) + lon1 <- c(10, 12) + + # dat2 + set.seed(2) + dat2 <- array(rnorm(120), dim = c(dat = 2, lat = 6, lon = 2, sdate = 5)) + lat2 <- lat1 + lon2 <- lon1 + +############################################## +test_that("1. Input checks", { + + # ano + expect_error( + REOF(c()), + "Parameter 'ano' cannot be NULL." + ) + expect_error( + REOF(c(NA, NA)), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + REOF(list(a = array(rnorm(50), dim = c(dat = 5, sdate = 10)), b = c(1:4))), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + REOF(array(1:10, dim = c(2, 5))), + "Parameter 'ano' must have dimension names." + ) + # time_dim + expect_error( + REOF(dat1, time_dim = 2), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + REOF(dat1, time_dim = c('a','sdate')), + "Parameter 'time_dim' must be a character string." + ) + # space_dim + expect_error( + REOF(dat1, space_dim = 'lat'), + "Parameter 'space_dim' must be a character vector of 2." + ) + expect_error( + REOF(dat1, space_dim = c('latitude', 'longitude')), + "Parameter 'space_dim' is not found in 'ano' dimension." + ) + # lat + expect_error( + REOF(dat1, lat = 1:10), + paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") + ) + expect_error( + REOF(dat1, lat = seq(-100, -80, length.out = 6)), + "Parameter 'lat' must contain values within the range \\[-90, 90\\]." + ) + # lon + expect_error( + REOF(dat1, lat = lat1, lon = c('a', 'b')), + paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") + ) + expect_warning( + REOF(dat1, lat = lat1, lon = c(350, 370)), + "Some 'lon' is out of the range \\[-360, 360\\]." + ) + # ntrunc + expect_error( + REOF(dat1, lat = lat1, lon = lon1, ntrunc = 0), + "Parameter 'ntrunc' must be a positive integer." + ) + # corr + expect_error( + REOF(dat1, lat = lat1, lon = lon1, corr = 0.1), + "Parameter 'corr' must be one logical value." + ) + # ncores + expect_error( + REOF(dat1, lat1, lon1, ncore = 3.5), + "Parameter 'ncores' must be a positive integer." + ) + +}) + +############################################## +test_that("2. dat1", { + + expect_equal( + names(REOF(dat1, lon = lon1, lat = lat1, ntrunc = 5)), + c("REOFs", "RPCs", "var", "wght") + ) + expect_equal( + dim(REOF(dat1, lon = lon1, lat = lat1)$REOFs), + c(mode = 10, lat = 6, lon = 2) + ) + expect_equal( + dim(REOF(dat1, lon = lon1, lat = lat1, ntrunc = 9)$RPCs), + c(sdate = 10, mode = 9) + ) + expect_equal( + dim(REOF(dat1, lon = lon1, lat = lat1, ntrunc = 1)$var), + c(mode = 1) + ) + expect_equal( + dim(REOF(dat1, lon = lon1, lat = lat1, ntrunc = 1)$wght), + c(lat = 6, lon = 2) + ) + expect_equal( + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 1)$REOFs[1:5], + c(-0.28881677, 0.47116712, 0.27298759, 0.32794052, 0.01873475), + tolerance = 0.0001 + ) + expect_equal( + mean(REOF(dat1, lon = lon1, lat = lat1, ntrunc = 2)$REOFs), + -0.007620167, + tolerance = 0.0001 + ) + expect_equal( + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 2)$RPCs[4:8], + c(-0.58817084, -1.86745710, -0.09939452, -1.11012382, 1.89513430), + tolerance = 0.0001 + ) + expect_equal( + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 2)$var[1:2], + array(c(28.04203, 26.56988), dim = c(mode = 2)), + tolerance = 0.0001 + ) + expect_equal( + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 1)$wght[1,1], + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 1)$wght[1,2] + ) + expect_equal( + REOF(dat1, lon = lon1, lat = lat1, ntrunc = 1)$wght[1:1], + c(0.9923748), + tolerance = 0.0001 + ) + +}) +############################################## +test_that("3. dat2", { + expect_equal( + dim(REOF(dat2, lon = lon2, lat = lat2)$REOFs), + c(mode = 5, lat = 6, lon = 2, dat = 2) + ) + expect_equal( + dim(REOF(dat2, lon = lon2, lat = lat2, ntrunc = 4)$RPCs), + c(sdate = 5, mode = 4, dat = 2) + ) + expect_equal( + REOF(dat2, lon = lon2, lat = lat2, ntrunc = 1)$REOFs[1, 3, 2, 1], + 0.09529009, + tolerance = 0.0001 + ) + expect_equal( + mean(REOF(dat2, lon = lon2, lat = lat2)$REOFs), + 0.01120786, + tolerance = 0.0001 + ) + +}) + -- GitLab From 8675aba74ec962e54d641f2ca8f347bebd7c0355 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 10 May 2021 21:35:19 +0200 Subject: [PATCH 20/28] Revise NAO()'s EOF calculation --- R/NAO.R | 191 +++++++++++++++-------------- R/ProjectField.R | 21 ++-- man/NAO.Rd | 42 +++---- tests/testthat/test-NAO.R | 64 +++++++--- tests/testthat/test-ProjectField.R | 10 +- 5 files changed, 173 insertions(+), 155 deletions(-) diff --git a/R/NAO.R b/R/NAO.R index a73536a..4af0308 100644 --- a/R/NAO.R +++ b/R/NAO.R @@ -3,9 +3,9 @@ #'Compute the North Atlantic Oscillation (NAO) index based on the leading EOF #'of the sea level pressure (SLP) anomalies over the north Atlantic region #'(20N-80N, 80W-40E). The PCs are obtained by projecting the forecast and -#'observed anomalies onto the observed EOF pattern (Pobs) or the forecast -#'anomalies onto the EOF pattern of the other years of the forecast (Pmod). -#'By default (ftime_avg = 2:4) NAO() computes the NAO index for 1-month +#'observed anomalies onto the observed EOF pattern or the forecast +#'anomalies onto the EOF pattern of the other years of the forecast. +#'By default (ftime_avg = 2:4), NAO() computes the NAO index for 1-month #'lead seasonal forecasts that can be plotted with PlotBoxWhisker(). It returns #'cross-validated PCs of the NAO index for forecast (exp) and observations #'(obs) based on the leading EOF pattern. @@ -17,7 +17,7 @@ #' be left to NULL. The default value is NULL. #'@param obs A named numeric array of North Atlantic SLP (20N-80N, 80W-40E) #' observed anomalies from \code{Ano()} or \code{Ano_CrossValid()} with -#' dimensions 'time_dim', 'memb_dim', 'ftime_dim', and 'space_dim' at least. +#' dimensions 'time_dim', 'ftime_dim', and 'space_dim' at least. #' If only NAO of experimental data needs to be computed, this parameter can #' be left to NULL. The default value is NULL. #'@param lat A vector of the latitudes of 'exp' and 'obs'. @@ -25,7 +25,8 @@ #'@param time_dim A character string indicating the name of the time dimension #' of 'exp' and 'obs'. The default value is 'sdate'. #'@param memb_dim A character string indicating the name of the member -#' dimension of 'exp' and 'obs'. The default value is 'member'. +#' dimension of 'exp' (and 'obs', optional). If 'obs' has memb_dim, the length +#' must be 1. The default value is 'member'. #'@param space_dim A vector of two character strings. The first is the dimension #' name of latitude of 'ano' and the second is the dimension name of longitude #' of 'ano'. The default value is c('lat', 'lon'). @@ -61,29 +62,16 @@ #' DOI: 10.1007/s00382-003-0350-4 #' #'@examples -#' \dontshow{ -#'startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') -#'sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), -#' c('observation'), startDates, -#' leadtimemin = 1, -#' leadtimemax = 4, -#' output = 'lonlat', -#' latmin = 27, latmax = 48, -#' lonmin = -12, 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 -#'# the NAO region directly. -#'sampleData$lon[] <- c(40, 280, 340) -#'sampleData$lat[] <- c(20, 80) -#' } +#'# Make up synthetic data +#'set.seed(1) +#'exp <- array(rnorm(1620), dim = c(member = 2, sdate = 3, ftime = 5, lat = 6, lon = 9)) +#'set.seed(2) +#'obs <- array(rnorm(1620), dim = c(member = 1, sdate = 3, ftime = 5, lat = 6, lon = 9)) +#'lat <- seq(20, 80, length.out = 6) +#'lon <- seq(-80, 40, length.out = 9) +#'nao <- NAO(exp = exp, obs = obs, lat = lat, lon = lon) #' -#'# Now ready to compute the EOFs and project on, for example, the first -#'# variability mode. -#'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -#'# Note that computing the NAO over the region for which there is available -#'# example data is not the full NAO area: NAO() will raise a warning. -#'nao <- NAO(ano$exp, ano$obs, sampleData$lat, sampleData$lon) -#'# Finally plot the NAO index +#'# plot the NAO index #' \dontrun{ #'nao$exp <- Reorder(nao$exp, c(2, 1)) #'nao$obs <- Reorder(nao$obs, c(2, 1)) @@ -109,7 +97,7 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', stop("Parameter 'exp' must be a numeric array.") } if (is.null(dim(exp))) { - stop(paste0("Parameter 'exp' and must have at least dimensions ", + stop(paste0("Parameter 'exp' must have at least dimensions ", "time_dim, memb_dim, space_dim, and ftime_dim.")) } if(any(is.null(names(dim(exp)))) | any(nchar(names(dim(exp))) == 0)) { @@ -121,8 +109,8 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', stop("Parameter 'obs' must be a numeric array.") } if (is.null(dim(obs))) { - stop(paste0("Parameter 'obs' and must have at least dimensions ", - "time_dim, memb_dim, space_dim, and ftime_dim.")) + stop(paste0("Parameter 'obs' must have at least dimensions ", + "time_dim, space_dim, and ftime_dim.")) } if(any(is.null(names(dim(obs)))) | any(nchar(names(dim(obs))) == 0)) { stop("Parameter 'obs' must have dimension names.") @@ -148,12 +136,19 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', } if (!is.null(exp)) { if (!memb_dim %in% names(dim(exp))) { - stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + stop("Parameter 'memb_dim' is not found in 'exp' dimension.") } } if (!is.null(obs)) { - if (!memb_dim %in% names(dim(obs))) { - stop("Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension.") + if (memb_dim %in% names(dim(obs))) { + if (dim(obs)[memb_dim] != 1) { + stop("The length of parameter 'memb_dim' in 'obs' must be 1.") + } else { + add_member_back <- TRUE + obs <- ClimProjDiags::Subset(obs, memb_dim, 1, drop = 'selected') + } + } else { + add_member_back <- FALSE } } ## space_dim @@ -189,10 +184,17 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', 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 the same length of ", - "all dimensions except 'memb_dim'.")) + throw_error <- FALSE + if (length(name_exp) != length(name_obs)) { + throw_error <- TRUE + } else if (any(name_exp != name_obs)) { + throw_error <- TRUE + } else if(!all(dim(exp)[name_exp] == dim(obs)[name_obs])) { + throw_error <- TRUE + } + if (throw_error) { + stop(paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions expect 'memb_dim'.")) } } ## ftime_avg @@ -239,8 +241,7 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', } } stop_needed <- FALSE - if (tail(lat, 1) < 70 | tail(lat, 1) > 90 | - head(lat, 1) > 30 | head(lat, 1) < 10) { + if (max(lat) > 80 | min(lat) < 20) { stop_needed <- TRUE } #NOTE: different from s2dverification @@ -286,122 +287,128 @@ NAO <- function(exp = NULL, obs = NULL, lat, lon, time_dim = 'sdate', } } - #-------- Average ftime ----------- + # Average ftime if (!is.null(exp)) { exp_sub <- ClimProjDiags::Subset(exp, ftime_dim, ftime_avg, drop = FALSE) exp <- MeanDims(exp_sub, ftime_dim, na.rm = TRUE) ## Cross-validated PCs. Fabian. This should be extended to ## nmod and nlt by simple loops. Virginie } - if (!is.null(obs)) { obs_sub <- ClimProjDiags::Subset(obs, ftime_dim, ftime_avg, drop = FALSE) obs <- MeanDims(obs_sub, ftime_dim, na.rm = TRUE) } + # wght + wght <- array(sqrt(cos(lat * pi/180)), dim = c(length(lat), length(lon))) + if (!is.null(exp) & !is.null(obs)) { res <- Apply(list(exp, obs), target_dims = list(exp = c(memb_dim, time_dim, space_dim), - obs = c(memb_dim, time_dim, space_dim)), + obs = c(time_dim, space_dim)), fun = .NAO, - obsproj = obsproj, lat = lat, lon = lon, + obsproj = obsproj, wght = wght, add_member_back = add_member_back, ncores = ncores) } else if (!is.null(exp)) { res <- Apply(list(exp = exp), target_dims = list(exp = c(memb_dim, time_dim, space_dim)), fun = .NAO, - obsproj = obsproj, lat = lat, lon = lon, obs = NULL, + obsproj = obsproj, wght = wght, obs = NULL, add_member_back = FALSE, ncores = ncores) } else if (!is.null(obs)) { + if (add_member_back) { + output_dims <- list(obs = c(time_dim, memb_dim)) + } else { + output_dims <- list(obs = time_dim) + } res <- Apply(list(obs = obs), - target_dims = list(obs = c(memb_dim, time_dim, space_dim)), + target_dims = list(obs = c(time_dim, space_dim)), + output_dims = output_dims, fun = .NAO, - obsproj = obsproj, lat = lat, lon = lon, exp = NULL, + obsproj = obsproj, wght = wght, exp = NULL, add_member_back = add_member_back, ncores = ncores) } return(res) } -.NAO <- function(exp = NULL, obs = NULL, lat, lon, - obsproj = TRUE, ncores = NULL) { +.NAO <- function(exp = NULL, obs = NULL, wght, obsproj = TRUE, add_member_back = FALSE) { # exp: [memb_exp, sdate, lat, lon] - # obs: [memb_obs, sdate, lat, lon] + # obs: [sdate, lat, lon] + # wght: [lat, lon] + if (!is.null(exp)) { ntime <- dim(exp)[2] nlat <- dim(exp)[3] nlon <- dim(exp)[4] nmemb_exp <- dim(exp)[1] - nmemb_obs <- dim(obs)[1] } else { - ntime <- dim(obs)[2] - nlat <- dim(obs)[3] - nlon <- dim(obs)[4] - nmemb_obs <- dim(obs)[1] + ntime <- dim(obs)[1] + nlat <- dim(obs)[2] + nlon <- dim(obs)[3] } - if (!is.null(obs)) NAOO.ver <- array(NA, dim = c(ntime, nmemb_obs)) + if (!is.null(obs)) NAOO.ver <- array(NA, dim = ntime) if (!is.null(exp)) NAOF.ver <- array(NA, dim = c(ntime, nmemb_exp)) for (tt in 1:ntime) { #sdate if (!is.null(obs)) { - ## Observed EOF excluding one forecast start year. - obs_sub <- ClimProjDiags::Subset(obs, 2, c(1:ntime)[-tt], drop = FALSE) - obs_EOF <- EOF(obs_sub, lat = lat, lon = lon, time_dim = names(ntime), - space_dim = c(names(nlat), names(nlon)), neofs = 1) + ## Calculate observation EOF. Excluding one forecast start year. + obs_sub <- obs[c(1:ntime)[-tt], , , drop = FALSE] + obs_EOF <- .EOF(obs_sub, neofs = 1, wght = wght) # $EOFs: [mode, lat, lon] ## Correct polarity of pattern. - #NOTE: different from s2dverification - # dim(obs_EOF$EOFs): [mode, lat, lon, member] - for (imemb in 1:nmemb_obs) { - if (0 < mean(obs_EOF$EOFs[1, which.min(abs(lat - 65)), , ], na.rm = T)) { - obs_EOF$EOFs[1, , , imemb] <- obs_EOF$EOFs[1, , , imemb] * (-1) - } + # dim(obs_EOF$EOFs): [mode, lat, lon] + if (0 < mean(obs_EOF$EOFs[1, which.min(abs(lat - 65)), ], na.rm = T)) { + obs_EOF$EOFs <- obs_EOF$EOFs * (-1) +# obs_EOF$PCs <- obs_EOF$PCs * (-1) # not used } -# obs_EOF$PCs <- obs_EOF$PCs * sign # not used - ## Project observed anomalies. - PF <- ProjectField(obs, eof = obs_EOF, time_dim = names(ntime), - space_dim = c(names(nlat), names(nlon)), mode = 1) - NAOO.ver[tt, ] <- PF[tt, ] + PF <- .ProjectField(obs, eof_mode = obs_EOF$EOFs[1, , ], wght = wght) # [sdate] ## Keep PCs of excluded forecast start year. Fabian. + NAOO.ver[tt] <- PF[tt] } if (!is.null(exp)) { if (!obsproj) { - exp_sub <- ClimProjDiags::Subset(exp, 2, c(1:ntime)[-tt], drop = FALSE) - #NOTE: different from s2dverification. Here, 'member' is considered. - exp_EOF <- EOF(exp_sub, lat = lat, lon = lon, time_dim = names(ntime), - space_dim = c(names(nlat), names(nlon)), neofs = 1) + exp_sub <- exp[, c(1:ntime)[-tt], , , drop = FALSE] + # Combine 'memb' and 'sdate' to calculate EOF + dim(exp_sub) <- c(nmemb_exp * (ntime - 1), nlat, nlon) + exp_EOF <- .EOF(exp_sub, neofs = 1, wght = wght) # $EOFs: [mode, lat, lon] ## Correct polarity of pattern. - #NOTE: different from s2dverification - for (imemb in 1:nmemb_exp) { - if (0 < mean(exp_EOF$EOFs[1, which.min(abs(lat - 65)), , imemb], na.rm = T)) { - exp_EOF$EOFs[1, , , imemb] <- exp_EOF$EOFs[1, , , imemb] * (-1) - } + ##NOTE: different from s2dverification, which doesn't use mean(). +# if (0 < exp_EOF$EOFs[1, which.min(abs(lat - 65)), ]) { + if (0 < mean(exp_EOF$EOFs[1, which.min(abs(lat - 65)), ], na.rm = T)) { + exp_EOF$EOFs <- exp_EOF$EOFs * (-1) +# exp_EOF$PCs <- exp_EOF$PCs * sign # not used } -# exp_EOF$PCs <- exp_EOF$PCs * sign # not used ### Lines below could be simplified further by computing ### ProjectField() only on the year of interest... (though this is ### not vital). Lauriane - PF <- ProjectField(exp, eof = exp_EOF, time_dim = names(ntime), - space_dim = c(names(nlat), names(nlon)), mode = 1) - NAOF.ver[tt, ] <- PF[tt, ] - + for (imemb in 1:nmemb_exp) { + PF <- .ProjectField(exp[imemb, , , ], eof_mode = exp_EOF$EOFs[1, , ], wght = wght) # [sdate, memb] + NAOF.ver[tt, imemb] <- PF[tt] + } } else { - ## Project forecast anomalies on obs EOF - #NOTE: Because obs and exp have different nmemb, do ensemble mean to - # obs_EOF$EOFs first, then expand the memb dim to be the same as exp. - obs_EOF$EOFs <- apply(obs_EOF$EOFs, c(1, 2, 3), mean, na.rm = T) - obs_EOF$EOFs <- array(obs_EOF$EOFs, dim = c(dim(obs_EOF$EOFs), as.numeric(nmemb_exp))) - names(dim(obs_EOF$EOFs))[4] <- names(nmemb_obs) - PF <- ProjectField(exp, obs_EOF, mode = 1) - NAOF.ver[tt, ] <- PF[tt, ] + ## Project forecast anomalies on obs EOF + for (imemb in 1:nmemb_exp) { + PF <- .ProjectField(exp[imemb, , , ], eof_mode = obs_EOF$EOFs[1, , ], wght = wght) # [sdate] + NAOF.ver[tt, imemb] <- PF[tt] + } } } + + } # for loop sdate + + # add_member_back + if (add_member_back) { + suppressWarnings( + NAOO.ver <- InsertDim(NAOO.ver, 2, 1, name = names(dim(exp))[1]) + ) } + #NOTE: EOFs_obs is not returned because it's only the result of the last sdate # (It is returned in s2dverification.) if (!is.null(exp) & !is.null(obs)) { diff --git a/R/ProjectField.R b/R/ProjectField.R index 2e9d26f..b6e2cd1 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -140,7 +140,7 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon if (all(names(dim(eof_mode)) %in% space_dim)) { # eof_mode: [lat, lon] res <- Apply(list(ano), - target_dims = list(c(space_dim, time_dim)), + target_dims = list(c(time_dim, space_dim)), output_dims = time_dim, eof_mode = eof_mode, wght = eof$wght, @@ -169,9 +169,8 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon lendim = additional_dims[i], name = names(additional_dims)[i]) } } - res <- Apply(list(ano, eof_mode), - target_dims = list(c(space_dim, time_dim), + target_dims = list(c(time_dim, space_dim), c(space_dim)), output_dims = time_dim, wght = eof$wght, @@ -184,22 +183,22 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon .ProjectField <- function(ano, eof_mode, wght) { - # ano: [lat, lon, sdate] + # ano: [sdate, lat, lon] # eof_mode: [lat, lon] # wght: [lat, lon] - dim_time <- dim(ano)[3] + ntime <- dim(ano)[1] # Initialization of pc.ver. - pc.ver <- array(NA, dim = dim_time) #[sdate] + pc.ver <- array(NA, dim = ntime) #[sdate] - # Weigths + # Weight e.1 <- eof_mode * wght - ano <- ano * InsertDim(wght, 3, dim_time) + ano <- ano * InsertDim(wght, 1, ntime) - na <- apply(ano, 3, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA - tmp <- ano * InsertDim(e.1, 3, dim_time) # [lat, lon, sdate] - pc.ver <- apply(tmp, 3, sum, na.rm = TRUE) + na <- apply(ano, 1, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA + tmp <- ano * InsertDim(e.1, 1, ntime) # [sdate, lat, lon] + pc.ver <- apply(tmp, 1, sum, na.rm = TRUE) pc.ver[which(is.na(na))] <- NA return(pc.ver) diff --git a/man/NAO.Rd b/man/NAO.Rd index c61a5ac..64b1656 100644 --- a/man/NAO.Rd +++ b/man/NAO.Rd @@ -27,7 +27,7 @@ be left to NULL. The default value is NULL.} \item{obs}{A named numeric array of North Atlantic SLP (20N-80N, 80W-40E) observed anomalies from \code{Ano()} or \code{Ano_CrossValid()} with -dimensions 'time_dim', 'memb_dim', 'ftime_dim', and 'space_dim' at least. +dimensions 'time_dim', 'ftime_dim', and 'space_dim' at least. If only NAO of experimental data needs to be computed, this parameter can be left to NULL. The default value is NULL.} @@ -39,7 +39,8 @@ be left to NULL. The default value is NULL.} of 'exp' and 'obs'. The default value is 'sdate'.} \item{memb_dim}{A character string indicating the name of the member -dimension of 'exp' and 'obs'. The default value is 'member'.} +dimension of 'exp' (and 'obs', optional). If 'obs' has memb_dim, the length +must be 1. The default value is 'member'.} \item{space_dim}{A vector of two character strings. The first is the dimension name of latitude of 'ano' and the second is the dimension name of longitude @@ -77,37 +78,24 @@ A list which contains: Compute the North Atlantic Oscillation (NAO) index based on the leading EOF of the sea level pressure (SLP) anomalies over the north Atlantic region (20N-80N, 80W-40E). The PCs are obtained by projecting the forecast and -observed anomalies onto the observed EOF pattern (Pobs) or the forecast -anomalies onto the EOF pattern of the other years of the forecast (Pmod). -By default (ftime_avg = 2:4) NAO() computes the NAO index for 1-month +observed anomalies onto the observed EOF pattern or the forecast +anomalies onto the EOF pattern of the other years of the forecast. +By default (ftime_avg = 2:4), NAO() computes the NAO index for 1-month lead seasonal forecasts that can be plotted with PlotBoxWhisker(). It returns cross-validated PCs of the NAO index for forecast (exp) and observations (obs) based on the leading EOF pattern. } \examples{ - \dontshow{ -startDates <- c('19851101', '19901101', '19951101', '20001101', '20051101') -sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), - c('observation'), startDates, - leadtimemin = 1, - leadtimemax = 4, - output = 'lonlat', - latmin = 27, latmax = 48, - lonmin = -12, 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 -# the NAO region directly. -sampleData$lon[] <- c(40, 280, 340) -sampleData$lat[] <- c(20, 80) - } +# Make up synthetic data +set.seed(1) +exp <- array(rnorm(1620), dim = c(member = 2, sdate = 3, ftime = 5, lat = 6, lon = 9)) +set.seed(2) +obs <- array(rnorm(1620), dim = c(member = 1, sdate = 3, ftime = 5, lat = 6, lon = 9)) +lat <- seq(20, 80, length.out = 6) +lon <- seq(-80, 40, length.out = 9) +nao <- NAO(exp = exp, obs = obs, lat = lat, lon = lon) -# Now ready to compute the EOFs and project on, for example, the first -# variability mode. -ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) -# Note that computing the NAO over the region for which there is available -# example data is not the full NAO area: NAO() will raise a warning. -nao <- NAO(ano$exp, ano$obs, sampleData$lat, sampleData$lon) -# Finally plot the NAO index +# plot the NAO index \dontrun{ nao$exp <- Reorder(nao$exp, c(2, 1)) nao$obs <- Reorder(nao$obs, c(2, 1)) diff --git a/tests/testthat/test-NAO.R b/tests/testthat/test-NAO.R index d0acbd5..f3c6d21 100644 --- a/tests/testthat/test-NAO.R +++ b/tests/testthat/test-NAO.R @@ -3,18 +3,18 @@ context("s2dv::NAO tests") ############################################## # dat1 set.seed(1) - exp1 <- array(rnorm(144), dim = c(member = 2, sdate = 3, ftime = 4, lat = 2, lon = 3)) + exp1 <- array(rnorm(144), dim = c(dataset = 1, member = 2, sdate = 3, ftime = 4, lat = 2, lon = 3)) set.seed(2) - obs1 <- array(rnorm(72), dim = c(member = 1, sdate = 3, ftime = 4, lat = 2, lon = 3)) + obs1 <- array(rnorm(72), dim = c(dataset = 1, member = 1, sdate = 3, ftime = 4, lat = 2, lon = 3)) lat1 <- c(20, 80) lon1 <- c(40, 280, 350) # dat2 set.seed(1) - exp2 <- array(rnorm(144), dim = c(sdate = 3, ftime = 4, member = 2, lat = 2, lon = 3)) + exp2 <- array(rnorm(216), dim = c(sdate = 3, ftime = 4, member = 2, lat = 3, lon = 3)) set.seed(2) - obs2 <- array(rnorm(144), dim = c(member = 2, sdate = 3, ftime = 4, lat = 2, lon = 3)) - lat2 <- c(20, 80) + obs2 <- array(rnorm(108), dim = c(sdate = 3, ftime = 4, lat = 3, lon = 3)) + lat2 <- c(80, 50, 20) lon2 <- c(-80, 0, 40) ############################################## @@ -31,7 +31,7 @@ test_that("1. Input checks", { ) expect_error( NAO(exp = c(1:10)), - paste0("Parameter 'exp' and must have at least dimensions ", + paste0("Parameter 'exp' must have at least dimensions ", "time_dim, memb_dim, space_dim, and ftime_dim.") ) expect_error( @@ -44,8 +44,8 @@ test_that("1. Input checks", { ) expect_error( NAO(exp = exp1, obs = c(1:10)), - paste0("Parameter 'obs' and must have at least dimensions ", - "time_dim, memb_dim, space_dim, and ftime_dim.") + paste0("Parameter 'obs' must have at least dimensions ", + "time_dim, space_dim, and ftime_dim.") ) expect_error( NAO(exp = exp1, obs = array(1:10, dim = c(2, 5))), @@ -65,9 +65,13 @@ test_that("1. Input checks", { NAO(exp1, obs1, memb_dim = 2), "Parameter 'memb_dim' must be a character string." ) + expect_error( + NAO(exp1, array(rnorm(10), dim = c(member = 10, sdate = 3, ftime = 4, lat = 2, lon = 2))), + "The length of parameter 'memb_dim' in 'obs' must be 1." + ) expect_error( NAO(exp1, obs1, memb_dim = 'a'), - "Parameter 'memb_dim' is not found in 'exp' or 'obs' dimension." + "Parameter 'memb_dim' is not found in 'exp' dimension." ) # space_dim expect_error( @@ -89,9 +93,14 @@ test_that("1. Input checks", { ) # exp and obs (2) expect_error( - NAO(exp1, array(rnorm(10), dim = c(member = 10, sdate = 3, ftime = 4, lat = 2, lon = 2))), - paste0("Parameter 'exp' and 'obs' must have the same length of ", - "all dimensions except 'memb_dim'.") + NAO(exp1, array(rnorm(10), dim = c(member = 1, sdate = 3, ftime = 4, lat = 2, lon = 2))), + paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions expect 'memb_dim'.") + ) + expect_error( + NAO(exp1, array(rnorm(10), dim = c(dataset = 1, member = 1, sdate = 3, ftime = 4, lat = 1, lon = 2))), + paste0("Parameter 'exp' and 'obs' must have the same names and lengths ", + "of all the dimensions expect 'memb_dim'.") ) # ftime_avg expect_error( @@ -105,7 +114,7 @@ test_that("1. Input checks", { # sdate >= 2 expect_error( NAO(exp = array(rnorm(10), dim = c(member = 10, sdate = 1, ftime = 4, lat = 2, lon = 2)), - obs = array(rnorm(10), dim = c(member = 10, sdate = 1, ftime = 4, lat = 2, lon = 2))), + obs = array(rnorm(10), dim = c(member = 1, sdate = 1, ftime = 4, lat = 2, lon = 2))), "The length of time_dim must be at least 2." ) # lat and lon @@ -159,11 +168,11 @@ test_that("2. dat1", { ) expect_equal( dim(NAO(exp1, obs1, lat = lat1, lon = lon1)$exp), - c(sdate = 3, member = 2) + c(sdate = 3, member = 2, dataset = 1) ) expect_equal( dim(NAO(exp1, obs1, lat = lat1, lon = lon1)$obs), - c(sdate = 3, member = 1) + c(sdate = 3, member = 1, dataset = 1) ) expect_equal( NAO(exp1, obs1, lat = lat1, lon = lon1)$exp[1:5], @@ -177,7 +186,7 @@ test_that("2. dat1", { ) expect_equal( mean(NAO(exp1, obs1, lat = lat1, lon = lon1, obsproj = FALSE)$exp), - -0.1362706, + -0.2263239, tolerance = 0.0001 ) expect_equal( @@ -190,6 +199,15 @@ test_that("2. dat1", { c("obs") ) ) + expect_equal( + dim(NAO(obs = obs1, lat = lat1, lon = lon1, obsproj = FALSE)$obs), + c(sdate = 3, member = 1, dataset = 1) + ) + expect_equal( + as.vector(NAO(obs = obs1, lat = lat1, lon = lon1, obsproj = FALSE)$obs), + c(-0.1139683, 0.1056687, 0.1889449), + tolerance = 0.0001 + ) }) ############################################## @@ -200,23 +218,29 @@ test_that("3. dat2", { ) expect_equal( dim(NAO(exp2, obs2, lat = lat2, lon = lon2)$obs), - c(sdate = 3, member = 2) + c(sdate = 3) ) expect_equal( mean(NAO(exp2, obs2, lat = lat2, lon = lon2)$exp), - -0.01566486, + 0.006805087, tolerance = 0.00001 ) expect_equal( NAO(exp2, obs2, lat = lat2, lon = lon2)$exp[2:4], - c(0.16231137, -0.10984650, -0.01871716), + c(0.07420822, 0.09383927, -0.17372708), tolerance = 0.00001 ) expect_equal( NAO(exp2, obs2, lat = lat2, lon = lon2, ftime_avg = 1:3)$exp[2:4], - c(-0.30102528, -0.06366782, 0.01639220), + c(0.01652294, -0.63365859, -0.74297551), tolerance = 0.00001 ) + expect_equal( + as.vector(NAO(exp = exp2, lat = lat2, lon = lon2, obsproj = FALSE)$exp), + c(-0.3529993, 0.4702901, 0.2185340, 0.1525028, 0.3759627, -0.4451322), + tolerance = 0.00001 + ) + }) ############################################## diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R index 3cf14d2..1ba0042 100644 --- a/tests/testthat/test-ProjectField.R +++ b/tests/testthat/test-ProjectField.R @@ -6,14 +6,14 @@ context("s2dv::ProjectField tests") dat1 <- array(rnorm(120), dim = c(sdate = 10, lat = 6, lon = 2)) lat1 <- seq(10, 30, length.out = 6) lon1 <- c(10, 12) - eof1 <- EOF(dat1, lat1, lon1) + eof1 <- EOF(dat1, lat1, lon1, neofs = 10) # dat2 set.seed(1) dat2 <- array(rnorm(48), dim = c(dat = 1, memb = 1, sdate = 6, ftime = 1, lat = 4, lon = 2)) lat2 <- seq(10, 30, length.out = 4) lon2 <- c(-5, 5) - eof2 <- EOF(dat2, lat2, lon2) + eof2 <- EOF(dat2, lat2, lon2, neofs = 6) # dat3 dat3 <- dat2 @@ -21,7 +21,7 @@ context("s2dv::ProjectField tests") names(dim(dat3)) <- names(dim(dat2)) lat3 <- seq(10, 30, length.out = 4) lon3 <- c(-5, 5) - eof3 <- EOF(dat3, lat3, lon3) + eof3 <- EOF(dat3, lat3, lon3, neofs = 6) # dat4 set.seed(1) @@ -30,7 +30,7 @@ context("s2dv::ProjectField tests") lon4 <- c(350, 355) set.seed(2) tmp <- array(rnorm(144), dim = c(dat = 2, sdate = 6, lat = 4, lon = 2)) - eof4 <- EOF(tmp, lat4, lon4) + eof4 <- EOF(tmp, lat4, lon4, neofs = 6) # dat5 set.seed(1) @@ -39,7 +39,7 @@ context("s2dv::ProjectField tests") lon5 <- c(0, 5, 10) set.seed(2) tmp <- array(rnorm(72), dim = c(sdate = 6, lat = 4, lon = 3)) - eof5 <- EOF(tmp, lat5, lon5) + eof5 <- EOF(tmp, lat5, lon5, neofs = 6) ############################################## test_that("1. Input checks", { -- GitLab From 255eac41c7ef9493adbadf4436655ec67eb98dbf Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 17 May 2021 12:25:52 +0200 Subject: [PATCH 21/28] Allow 'mode' to be NULL --- R/ProjectField.R | 117 ++++++++++++++++++++--------- man/ProjectField.Rd | 9 ++- tests/testthat/test-ProjectField.R | 54 ++++++++----- 3 files changed, 125 insertions(+), 55 deletions(-) diff --git a/R/ProjectField.R b/R/ProjectField.R index b6e2cd1..2643f45 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -17,7 +17,8 @@ #' name of latitude of 'ano' and the second is the dimension name of longitude #' of 'ano'. The default value is c('lat', 'lon'). #'@param mode An integer of the variability mode number in the EOF to be -#' projected on. The default value is 1. +#' projected on. The default value is NULL, which means all the modes of 'eof' +#' is calculated. #'@param ncores An integer indicating the number of cores to use for parallel #' computation. The default value is NULL. #' @@ -39,8 +40,8 @@ #'ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) #'eof_exp <- EOF(ano$exp, sampleData$lat, sampleData$lon) #'eof_obs <- EOF(ano$obs, sampleData$lat, sampleData$lon) -#'mode1_exp <- ProjectField(ano$exp, eof_exp) -#'mode1_obs <- ProjectField(ano$obs, eof_obs) +#'mode1_exp <- ProjectField(ano$exp, eof_exp, mode = 1) +#'mode1_obs <- ProjectField(ano$obs, eof_obs, mode = 1) #' #'\dontrun{ #' # Plot the forecast and the observation of the first mode for the last year @@ -58,7 +59,7 @@ #'@import multiApply #'@export ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon'), - mode = 1, ncores = NULL) { + mode = NULL, ncores = NULL) { # Check inputs ## ano (1) @@ -117,12 +118,14 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon "with dimensions named as parameter 'space_dim'.")) } ## mode - if (!is.numeric(mode) | mode %% 1 != 0 | mode < 0 | length(mode) > 1) { - stop("Parameter 'mode' must be a positive integer.") - } - if (mode > dim(eof$EOFs)['mode']) { - stop(paste0("Parameter 'mode' is greater than the number of available ", - "modes in EOF.")) + if (!is.null(mode)) { + if (!is.numeric(mode) | mode %% 1 != 0 | mode < 0 | length(mode) > 1) { + stop("Parameter 'mode' must be NULL or a positive integer.") + } + if (mode > dim(eof$EOFs)['mode']) { + stop(paste0("Parameter 'mode' is greater than the number of available ", + "modes in EOF.")) + } } ## ncores if (!is.null(ncores)) { @@ -135,28 +138,46 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon #------------------------------------------------------- # Keep the chosen mode - eof_mode <- Subset(eof$EOFs, 'mode', mode, drop = 'selected') + if (!is.null(mode)) { + eof_mode <- ClimProjDiags::Subset(eof$EOFs, 'mode', mode, drop = 'selected') + } else { + eof_mode <- eof$EOFs + } - if (all(names(dim(eof_mode)) %in% space_dim)) { # eof_mode: [lat, lon] + if ('mode' %in% names(dim(eof_mode))) { + dimnames_without_mode <- names(dim(eof_mode))[-which(names(dim(eof_mode)) == 'mode')] + } else { + dimnames_without_mode <- names(dim(eof_mode)) + } - res <- Apply(list(ano), - target_dims = list(c(time_dim, space_dim)), - output_dims = time_dim, - eof_mode = eof_mode, + if (all(dimnames_without_mode %in% space_dim)) { # eof_mode: [lat, lon] or [mode, lat, lon] + if ('mode' %in% names(dim(eof_mode))) { + eof_mode_target <- c('mode', space_dim) + output_dims <- c('mode', time_dim) + } else { + eof_mode_target <- space_dim + output_dims <- time_dim + } + res <- Apply(list(ano, eof_mode), + target_dims = list(c(time_dim, space_dim), + eof_mode_target), + output_dims = output_dims, wght = eof$wght, fun = .ProjectField, ncores = ncores)$output1 } else { - if (!all(names(dim(eof_mode)) %in% names(dim(ano)))) { + + if (!all(dimnames_without_mode %in% names(dim(ano)))) { stop(paste0("The array 'EOF' in parameter 'eof' has dimension not in parameter ", "'ano'. Check if 'ano' and 'eof' are compatible.")) } - common_dim_ano <- dim(ano)[which(names(dim(ano)) %in% names(dim(eof_mode)))] - if (any(sort(common_dim_ano) != sort(dim(eof_mode)))) { - stop(paste0("Found paramter 'ano' and 'EOF' in parameter 'eof' have different ", - "common dimensions. Check if 'ano' and 'eof' are compatible.")) + common_dim_ano <- dim(ano)[which(names(dim(ano)) %in% dimnames_without_mode)] + if (any(common_dim_ano[match(dimnames_without_mode, names(common_dim_ano))] != + dim(eof_mode)[dimnames_without_mode])) { + stop(paste0("Found paramter 'ano' and 'EOF' in parameter 'eof' have common dimensions ", + "with different length. Check if 'ano' and 'eof' are compatible.")) } # Enlarge eof/ano is needed. The margin_dims of Apply() must be consistent @@ -169,10 +190,17 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon lendim = additional_dims[i], name = names(additional_dims)[i]) } } + if ('mode' %in% names(dim(eof_mode))) { + eof_mode_target <- c('mode', space_dim) + output_dims <- c('mode', time_dim) + } else { + eof_mode_target <- space_dim + output_dims <- time_dim + } res <- Apply(list(ano, eof_mode), target_dims = list(c(time_dim, space_dim), - c(space_dim)), - output_dims = time_dim, + eof_mode_target), + output_dims = output_dims, wght = eof$wght, fun = .ProjectField, ncores = ncores)$output1 @@ -184,22 +212,43 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon .ProjectField <- function(ano, eof_mode, wght) { # ano: [sdate, lat, lon] - # eof_mode: [lat, lon] + # eof_mode: [lat, lon] or [mode, lat, lon] # wght: [lat, lon] ntime <- dim(ano)[1] - # Initialization of pc.ver. - pc.ver <- array(NA, dim = ntime) #[sdate] + if (length(dim(eof_mode)) == 2) { # mode != NULL + # Initialization of pc.ver. + pc.ver <- array(NA, dim = ntime) #[sdate] - # Weight - e.1 <- eof_mode * wght - ano <- ano * InsertDim(wght, 1, ntime) - - na <- apply(ano, 1, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA - tmp <- ano * InsertDim(e.1, 1, ntime) # [sdate, lat, lon] - pc.ver <- apply(tmp, 1, sum, na.rm = TRUE) - pc.ver[which(is.na(na))] <- NA + # Weight + e.1 <- eof_mode * wght + ano <- ano * InsertDim(wght, 1, ntime) + + na <- apply(ano, 1, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA + tmp <- ano * InsertDim(e.1, 1, ntime) # [sdate, lat, lon] + pc.ver <- apply(tmp, 1, sum, na.rm = TRUE) + pc.ver[which(is.na(na))] <- NA + + } else { # mode = NULL + # Weight + e.1 <- eof_mode * InsertDim(wght, 1, dim(eof_mode)[1]) + dim(e.1) <- c(dim(eof_mode)[1], prod(dim(eof_mode)[2:3])) # [mode, lat*lon] + ano <- ano * InsertDim(wght, 1, ntime) + dim(ano) <- c(ntime, prod(dim(ano)[2:3])) # [sdate, lat*lon] + + na <- apply(ano, 1, mean, na.rm = TRUE) # if [lat, lon] all NA, it's NA + na <- aperm(array(na, dim = c(ntime, dim(e.1)[1])), c(2, 1)) + + # Matrix multiplication e.1 [mode, lat*lon] by ano [lat*lon, sdate] + # Result: [mode, sdate] + pc.ver <- e.1 %*% t(ano) + pc.ver[which(is.na(na))] <- NA + +# # Change back dimensions to feet original input +# dim(projection) <- c(moredims, mode = unname(neofs)) +# return(projection) + } return(pc.ver) } diff --git a/man/ProjectField.Rd b/man/ProjectField.Rd index 97353ff..2abeca0 100644 --- a/man/ProjectField.Rd +++ b/man/ProjectField.Rd @@ -9,7 +9,7 @@ ProjectField( eof, time_dim = "sdate", space_dim = c("lat", "lon"), - mode = 1, + mode = NULL, ncores = NULL ) } @@ -30,7 +30,8 @@ name of latitude of 'ano' and the second is the dimension name of longitude of 'ano'. The default value is c('lat', 'lon').} \item{mode}{An integer of the variability mode number in the EOF to be -projected on. The default value is 1.} +projected on. The default value is NULL, which means all the modes of 'eof' +is calculated.} \item{ncores}{An integer indicating the number of cores to use for parallel computation. The default value is NULL.} @@ -59,8 +60,8 @@ sampleData <- s2dv:::.LoadSampleData('tos', c('experiment'), ano <- Ano_CrossValid(sampleData$mod, sampleData$obs) eof_exp <- EOF(ano$exp, sampleData$lat, sampleData$lon) eof_obs <- EOF(ano$obs, sampleData$lat, sampleData$lon) -mode1_exp <- ProjectField(ano$exp, eof_exp) -mode1_obs <- ProjectField(ano$obs, eof_obs) +mode1_exp <- ProjectField(ano$exp, eof_exp, mode = 1) +mode1_obs <- ProjectField(ano$obs, eof_obs, mode = 1) \dontrun{ # Plot the forecast and the observation of the first mode for the last year diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R index 1ba0042..b01fc6d 100644 --- a/tests/testthat/test-ProjectField.R +++ b/tests/testthat/test-ProjectField.R @@ -19,9 +19,9 @@ context("s2dv::ProjectField tests") dat3 <- dat2 dat3[1, 1, 1, 1, , ] <- NA names(dim(dat3)) <- names(dim(dat2)) - lat3 <- seq(10, 30, length.out = 4) - lon3 <- c(-5, 5) - eof3 <- EOF(dat3, lat3, lon3, neofs = 6) + lat3 <- lat2 + lon3 <- lon2 + eof3 <- eof2 # dat4 set.seed(1) @@ -121,7 +121,7 @@ test_that("1. Input checks", { # mode expect_error( ProjectField(dat1, eof1, mode = -1), - "Parameter 'mode' must be a positive integer." + "Parameter 'mode' must be NULL or a positive integer." ) expect_error( ProjectField(dat1, eof1, mode = 15), @@ -139,11 +139,15 @@ test_that("1. Input checks", { test_that("2. dat1", { expect_equal( - dim(ProjectField(dat1, eof = eof1)), + dim(ProjectField(dat1, eof = eof1, mode = 1)), c(sdate = 10) ) expect_equal( - as.vector(ProjectField(dat1, eof1))[1:5], + dim(ProjectField(dat1, eof = eof1)), + c(mode = 10, sdate = 10) + ) + expect_equal( + as.vector(ProjectField(dat1, eof1, mode = 1))[1:5], c(3.2061306, -0.1692669, 0.5420990, -2.5324441, -0.6143680), tolerance = 0.0001 ) @@ -152,16 +156,24 @@ test_that("2. dat1", { c(-0.24848299, -0.19311118, -0.16951195, -0.10000207, 0.04554693), tolerance = 0.0001 ) + expect_equal( + as.vector(ProjectField(dat1, eof1, mode = 1)), + as.vector(ProjectField(dat1, eof1)[1, ]) + ) }) ############################################## test_that("3. dat2", { expect_equal( - dim(ProjectField(dat2, eof2)), + dim(ProjectField(dat2, eof2, mode = 1)), c(sdate = 6, dat = 1, memb = 1, ftime = 1) ) expect_equal( - ProjectField(dat2, eof2)[1:6], + dim(ProjectField(dat2, eof2)), + c(mode = 6, sdate = 6, dat = 1, memb = 1, ftime = 1) + ) + expect_equal( + ProjectField(dat2, eof2, mode = 1)[1:6], c(0.00118771, -1.20872474, -0.00821559, -2.06064916, -0.19245169, 2.26026937), tolerance = 0.0001 ) @@ -170,18 +182,26 @@ test_that("3. dat2", { 0.1741076, tolerance = 0.0001 ) + expect_equal( + as.vector(ProjectField(dat2, eof2, mode = 1)), + as.vector(ProjectField(dat2, eof2)[1, , , , ]) + ) + expect_equal( + as.vector(ProjectField(dat2, eof2, mode = 5)), + as.vector(ProjectField(dat2, eof2)[5, , , , ]) + ) }) ############################################## test_that("4. dat3", { expect_equal( - dim(ProjectField(dat3, eof3)), + dim(ProjectField(dat3, eof3, mode = 1)), c(sdate = 6, dat = 1, memb = 1, ftime = 1) ) expect_equal( - ProjectField(dat3, eof3)[1:6], - c(NA, 0, 0, 0, 0, 0), + ProjectField(dat3, eof3, mode = 1)[1:6], + c(NA, -1.20872474, -0.00821559, -2.06064916, -0.19245169, 2.26026937), tolerance = 0.0001 ) @@ -189,16 +209,16 @@ test_that("4. dat3", { ############################################## test_that("5. dat4", { expect_equal( - dim(ProjectField(dat4, eof4)), + dim(ProjectField(dat4, eof4, mode = 1)), c(sdate = 6, dat = 2, memb = 2, ftime = 3) ) expect_equal( - mean(ProjectField(dat4, eof4)), + mean(ProjectField(dat4, eof4, mode = 1)), 0.078082, tolerance = 0.0001 ) expect_equal( - ProjectField(dat4, eof4)[, 1, 2, 2], + ProjectField(dat4, eof4, mode = 1)[, 1, 2, 2], c(0.28137048, -0.17616154, -0.39155370, 0.08288953, 1.18465521, 0.81850535), tolerance = 0.0001 ) @@ -207,16 +227,16 @@ test_that("5. dat4", { ############################################## test_that("6. dat5", { expect_equal( - dim(ProjectField(dat5, eof5)), + dim(ProjectField(dat5, eof5, mode = 1)), c(sdate = 6, dat = 1, memb = 2, ftime = 3) ) expect_equal( - mean(ProjectField(dat5, eof5)), + mean(ProjectField(dat5, eof5, mode = 1)), 0.0907149, tolerance = 0.0001 ) expect_equal( - ProjectField(dat5, eof5)[, 1, 2, 2], + ProjectField(dat5, eof5, mode = 1)[, 1, 2, 2], c(0.60881970, 0.93588392, 0.01982465, 0.82376024, -0.33147699, -1.35488289), tolerance = 0.0001 ) -- GitLab From 6e440536b810fd5ff0c3ba88cccb1722a317915f Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 17 May 2021 15:09:04 +0200 Subject: [PATCH 22/28] Allow REOFs to be the input of ProjectField --- R/ProjectField.R | 44 ++++++++++++++++++------------ R/REOF.R | 7 ++--- man/ProjectField.Rd | 11 ++++---- tests/testthat/test-ProjectField.R | 41 ++++++++++++++++++++++++---- tests/testthat/test-REOF.R | 4 +++ 5 files changed, 75 insertions(+), 32 deletions(-) diff --git a/R/ProjectField.R b/R/ProjectField.R index 2643f45..7432632 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -2,15 +2,16 @@ #' #'Project anomalies onto modes of variability to get the temporal evolution of #'the EOF mode selected. It returns principal components (PCs) by area-weighted -#'projection onto EOF pattern (from \code{EOF()}). The calculation removes NA -#'and returns NA if the whole spatial pattern is NA. +#'projection onto EOF pattern (from \code{EOF()} or \code{REOF()}). The +#'calculation removes NA and returns NA if the whole spatial pattern is NA. #' #'@param ano A numerical array of anomalies with named dimensions. The #' dimensions must have at least 'time_dim' and 'space_dim'. It can be #' generated by Ano(). -#'@param eof A list that contains at least 'EOFs' and 'wght', which are both -#' arrays. 'EOFs' must have dimensions 'mode' and 'space_dim' at least. -#' 'wght' has dimensions space_dim. It can be generated by EOF(). +#'@param eof A list that contains at least 'EOFs' or 'REOFs' and 'wght', which +#' are both arrays. 'EOFs' or 'REOFs' must have dimensions 'mode' and +#' 'space_dim' at least. 'wght' has dimensions space_dim. It can be generated +#' by EOF() or REOF(). #'@param time_dim A character string indicating the name of the time dimension #' of 'ano'. The default value is 'sdate'. #'@param space_dim A vector of two character strings. The first is the dimension @@ -77,13 +78,22 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon stop("Parameter 'eof' cannot be NULL.") } if (!is.list(eof)) { - stop("Parameter 'eof' must be a list generated by EOF().") + stop("Parameter 'eof' must be a list generated by EOF() or REOF().") } - if (!all(c('EOFs', 'wght') %in% names(eof))) { - stop("Parameter 'eof' must contain 'EOFs' and 'wght' generated by EOF().") + if ('EOFs' %in% names(eof)) { + EOFs <- "EOFs" + } else if ('REOFs' %in% names(eof)) { + EOFs <- "REOFs" + } else { + stop(paste0("Parameter 'eof' must be a list that contains 'EOFs' or 'REOFs'. ", + "It can be generated by EOF() or REOF().")) + } + if (!'wght' %in% names(eof)) { + stop(paste0("Parameter 'eof' must be a list that contains 'wght'. ", + "It can be generated by EOF() or REOF().")) } - if (!is.numeric(eof$EOFs) || !is.array(eof$EOFs)) { - stop("The component 'EOFs' of parameter 'eof' must be a numeric array.") + if (!is.numeric(eof[[EOFs]]) || !is.array(eof[[EOFs]])) { + stop("The component 'EOFs' or 'REOFs' of parameter 'eof' must be a numeric array.") } if (!is.numeric(eof$wght) || !is.array(eof$wght)) { stop("The component 'wght' of parameter 'eof' must be a numeric array.") @@ -108,9 +118,9 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon "parameter 'space_dim' and 'time_dim'.")) } ## eof (2) - if (!all(space_dim %in% names(dim(eof$EOFs))) | - !'mode' %in% names(dim(eof$EOFs))) { - stop(paste0("The component 'EOFs' of parameter 'eof' must be an array ", + if (!all(space_dim %in% names(dim(eof[[EOFs]]))) | + !'mode' %in% names(dim(eof[[EOFs]]))) { + stop(paste0("The component 'EOFs' or 'REOFs' of parameter 'eof' must be an array ", "with dimensions named as parameter 'space_dim' and 'mode'.")) } if (length(dim(eof$wght)) != 2 | !all(names(dim(eof$wght)) %in% space_dim)) { @@ -122,9 +132,9 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon if (!is.numeric(mode) | mode %% 1 != 0 | mode < 0 | length(mode) > 1) { stop("Parameter 'mode' must be NULL or a positive integer.") } - if (mode > dim(eof$EOFs)['mode']) { + if (mode > dim(eof[[EOFs]])['mode']) { stop(paste0("Parameter 'mode' is greater than the number of available ", - "modes in EOF.")) + "modes in 'eof'.")) } } ## ncores @@ -139,9 +149,9 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon # Keep the chosen mode if (!is.null(mode)) { - eof_mode <- ClimProjDiags::Subset(eof$EOFs, 'mode', mode, drop = 'selected') + eof_mode <- ClimProjDiags::Subset(eof[[EOFs]], 'mode', mode, drop = 'selected') } else { - eof_mode <- eof$EOFs + eof_mode <- eof[[EOFs]] } if ('mode' %in% names(dim(eof_mode))) { diff --git a/R/REOF.R b/R/REOF.R index 30ef6f0..2a32b8e 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -158,13 +158,12 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', target_dims = c(time_dim, space_dim), output_dims = list(REOFs = c('mode', space_dim), RPCs = c(time_dim, 'mode'), - var = 'mode', - wght = space_dim), + var = 'mode'), fun = .REOF, corr = corr, ntrunc = ntrunc, wght = wght, ncores = ncores) - return(res) + return(c(res, wght = list(wght))) } @@ -213,5 +212,5 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', var <- apply(RPCs, 2, function(x) { sum(x*x) } ) * 100 / eofs$tot_var # [mode] dim(var) <- c(mode = length(var)) - return(invisible(list(REOFs = REOFs, RPCs = RPCs, var = var, wght = wght))) + return(invisible(list(REOFs = REOFs, RPCs = RPCs, var = var))) } diff --git a/man/ProjectField.Rd b/man/ProjectField.Rd index 2abeca0..1b3833f 100644 --- a/man/ProjectField.Rd +++ b/man/ProjectField.Rd @@ -18,9 +18,10 @@ ProjectField( dimensions must have at least 'time_dim' and 'space_dim'. It can be generated by Ano().} -\item{eof}{A list that contains at least 'EOFs' and 'wght', which are both -arrays. 'EOFs' must have dimensions 'mode' and 'space_dim' at least. -'wght' has dimensions space_dim. It can be generated by EOF().} +\item{eof}{A list that contains at least 'EOFs' or 'REOFs' and 'wght', which +are both arrays. 'EOFs' or 'REOFs' must have dimensions 'mode' and +'space_dim' at least. 'wght' has dimensions space_dim. It can be generated +by EOF() or REOF().} \item{time_dim}{A character string indicating the name of the time dimension of 'ano'. The default value is 'sdate'.} @@ -43,8 +44,8 @@ A numerical array of the principal components in the verification \description{ Project anomalies onto modes of variability to get the temporal evolution of the EOF mode selected. It returns principal components (PCs) by area-weighted -projection onto EOF pattern (from \code{EOF()}). The calculation removes NA -and returns NA if the whole spatial pattern is NA. +projection onto EOF pattern (from \code{EOF()} or \code{REOF()}). The +calculation removes NA and returns NA if the whole spatial pattern is NA. } \examples{ \dontshow{ diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R index b01fc6d..5e0fca6 100644 --- a/tests/testthat/test-ProjectField.R +++ b/tests/testthat/test-ProjectField.R @@ -7,6 +7,7 @@ context("s2dv::ProjectField tests") lat1 <- seq(10, 30, length.out = 6) lon1 <- c(10, 12) eof1 <- EOF(dat1, lat1, lon1, neofs = 10) + reof1 <- REOF(dat1, lat1, lon1, ntrunc = 3) # dat2 set.seed(1) @@ -31,6 +32,7 @@ context("s2dv::ProjectField tests") set.seed(2) tmp <- array(rnorm(144), dim = c(dat = 2, sdate = 6, lat = 4, lon = 2)) eof4 <- EOF(tmp, lat4, lon4, neofs = 6) + reof4 <- REOF(tmp, lat4, lon4, ntrunc = 6) # dat5 set.seed(1) @@ -67,17 +69,20 @@ test_that("1. Input checks", { "Parameter 'eof' cannot be NULL." ) expect_error( - ProjectField(dat1, c(1, 2, 3)), - "Parameter 'eof' must be a list generated by EOF()." + ProjectField(dat1, c(1, 2)), + "Parameter 'eof' must be a list generated by EOF() or REOF().", + fixed = TRUE ) expect_error( ProjectField(dat1, list(a = 1)), - "Parameter 'eof' must contain 'EOFs' and 'wght' generated by EOF()." + paste0("Parameter 'eof' must be a list that contains 'EOFs' or 'REOFs'. ", + "It can be generated by EOF() or REOF()."), + fixed = TRUE ) eof_fake <- list(EOFs = 'a', wght = 1:10) expect_error( ProjectField(dat1, eof_fake), - "The component 'EOFs' of parameter 'eof' must be a numeric array." + "The component 'EOFs' or 'REOFs' of parameter 'eof' must be a numeric array." ) eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 2, lon = 5)), wght = c(1:10)) @@ -108,7 +113,7 @@ test_that("1. Input checks", { wght = array(rnorm(10), dim = c(lat = 2, lon = 5))) expect_error( ProjectField(dat1, eof_fake), - paste0("The component 'EOFs' of parameter 'eof' must be an array ", + paste0("The component 'EOFs' or 'REOFs' of parameter 'eof' must be an array ", "with dimensions named as parameter 'space_dim' and 'mode'.") ) eof_fake <- list(EOFs = array(rnorm(10), dim = c(mode = 1, lat = 6, lon = 2)), @@ -126,7 +131,7 @@ test_that("1. Input checks", { expect_error( ProjectField(dat1, eof1, mode = 15), paste0("Parameter 'mode' is greater than the number of available ", - "modes in EOF.") + "modes in 'eof'.") ) # ncores expect_error( @@ -160,6 +165,20 @@ test_that("2. dat1", { as.vector(ProjectField(dat1, eof1, mode = 1)), as.vector(ProjectField(dat1, eof1)[1, ]) ) + # reof + expect_equal( + dim(ProjectField(dat1, eof = reof1, mode = 1)), + c(sdate = 10) + ) + expect_equal( + dim(ProjectField(dat1, eof = reof1)), + c(mode = 3, sdate = 10) + ) + expect_equal( + as.vector(ProjectField(dat1, reof1, mode = 1))[1:5], + c(3.1567219, -0.1023512, 0.6339372, -0.7998676, -1.3727226), + tolerance = 0.0001 + ) }) ############################################## @@ -222,6 +241,16 @@ test_that("5. dat4", { c(0.28137048, -0.17616154, -0.39155370, 0.08288953, 1.18465521, 0.81850535), tolerance = 0.0001 ) + # reof + expect_equal( + dim(ProjectField(dat4, reof4)), + c(mode = 6, sdate = 6, dat = 2, memb = 2, ftime = 3) + ) + expect_equal( + ProjectField(dat4, reof4, mode = 1)[, 1, 2, 2], + c(-1.6923627, -0.4080116, 0.3044336, -0.7853220, -0.2670783, 0.6940482), + tolerance = 0.0001 + ) }) ############################################## diff --git a/tests/testthat/test-REOF.R b/tests/testthat/test-REOF.R index 296e57a..c109d38 100644 --- a/tests/testthat/test-REOF.R +++ b/tests/testthat/test-REOF.R @@ -154,6 +154,10 @@ test_that("3. dat2", { c(sdate = 5, mode = 4, dat = 2) ) expect_equal( + dim(REOF(dat2, lon = lon2, lat = lat2, ntrunc = 2)$wght), + c(lat = 6, lon = 2) + ) + expect_equal( REOF(dat2, lon = lon2, lat = lat2, ntrunc = 1)$REOFs[1, 3, 2, 1], 0.09529009, tolerance = 0.0001 -- GitLab From 544b2f10f185b1a9180563976b715323bffd90f2 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 18 May 2021 13:05:48 +0200 Subject: [PATCH 23/28] Add new function EuroAtlanticTC --- NAMESPACE | 1 + R/EuroAtlanticTC.R | 200 ++++++++++++++++++ R/REOF.R | 32 +-- man/EuroAtlanticTC.Rd | 82 ++++++++ man/REOF.Rd | 22 +- tests/testthat/test-EuroAtlanticTC.R | 304 +++++++++++++++++++++++++++ tests/testthat/test-REOF.R | 5 +- 7 files changed, 620 insertions(+), 26 deletions(-) create mode 100644 R/EuroAtlanticTC.R create mode 100644 man/EuroAtlanticTC.Rd create mode 100644 tests/testthat/test-EuroAtlanticTC.R diff --git a/NAMESPACE b/NAMESPACE index 75ded15..94af45c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(ConfigShowTable) export(Corr) export(EOF) export(Eno) +export(EuroAtlanticTC) export(GMST) export(GSAT) export(Histo2Hindcast) diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R new file mode 100644 index 0000000..1d2c143 --- /dev/null +++ b/R/EuroAtlanticTC.R @@ -0,0 +1,200 @@ +#'Teleconnection indices in European Atlantic Ocean region +#' +#'Calculate the four main teleconnection indices in European Atlantic Ocean +#'region: North Atlantic oscillation (NAO), East Atlantic Pattern (EA), East +#'Atlantic/Western Russia (EAWR), and Scandinavian pattern (SCA). The function +#'\code{REOF()} is used for the calculation, and the first four modes are +#'returned. +#' +#'@param ano A numerical array of anomalies with named dimensions to calculate +#' REOF then the four teleconnections. The dimensions must have at least +#' 'time_dim' and 'space_dim', and the data should cover the European Atlantic +#' Ocean area (20N-80N, 90W-60E). +#'@param lat A vector of the latitudes of 'ano'. It should be 20N-80N. +#'@param lon A vector of the longitudes of 'ano'. It should be 90W-60E. +#'@param time_dim A character string indicating the name of the time dimension +#' of 'ano'. The default value is 'sdate'. +#'@param space_dim A vector of two character strings. The first is the dimension +#' name of latitude of 'ano' and the second is the dimension name of longitude +#' of 'ano'. The default value is c('lat', 'lon'). +#'@param ntrunc A positive integer of the modes to be kept. The default value +#' is 30. If time length or the product of latitude length and longitude +#' length is less than ntrunc, ntrunc is equal to the minimum of the three +#' values. +#'@param corr A logical value indicating whether to base on a correlation (TRUE) +#' or on a covariance matrix (FALSE). The default value is FALSE. +#'@param ncores An integer indicating the number of cores to use for parallel +#' computation. The default value is NULL. +#' +#'@return +#'A list containing: +#'\item{patterns}{ +#' An array of the first four REOF patterns normalized to 1 (unitless) with +#' dimensions (modes = 4, the rest of the dimensions of 'ano' except +#' 'time_dim'). Multiplying 'patterns' by 'indices' gives the original +#' reconstructed field. +#'} +#'\item{indices}{ +#' An array of the first four principal components with the units of the +#' original field to the power of 2, with dimensions (time_dim, modes = 4, the +#' rest of the dimensions of 'ano' except 'space_dim'). +#'} +#'\item{var}{ +#' An array of the percentage (%) of variance fraction of total variance +#' explained by each mode. The dimensions are (modes = ntrunc, the rest of the +#' dimensions of 'ano' except 'time_dim' and 'space_dim'). +#'} +#'\item{wght}{ +#' An array of the area weighting with dimensions 'space_dim'. It is calculated +#' by the square root of cosine of 'lat' and used to compute the fraction of +#' variance explained by each REOFs. +#'} +#'@examples +#' +#'@seealso REOF NAO +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +EuroAtlanticTC <- function(ano, lat, lon, ntrunc = 30, time_dim = 'sdate', + space_dim = c('lat', 'lon'), corr = FALSE, + ncores = NULL) { + + # Check inputs + ## ano + if (is.null(ano)) { + stop("Parameter 'ano' cannot be NULL.") + } + if (!is.numeric(ano)) { + stop("Parameter 'ano' must be a numeric array.") + } + if(any(is.null(names(dim(ano))))| any(nchar(names(dim(ano))) == 0)) { + stop("Parameter 'ano' 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(ano))) { + stop("Parameter 'time_dim' is not found in 'ano' dimension.") + } + ## space_dim + if (!is.character(space_dim) | length(space_dim) != 2) { + stop("Parameter 'space_dim' must be a character vector of 2.") + } + if (any(!space_dim %in% names(dim(ano)))) { + stop("Parameter 'space_dim' is not found in 'ano' dimension.") + } + ## lat and lon + if (!is.numeric(lat) | length(lat) != dim(ano)[space_dim[1]]) { + stop(paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.")) + } + if (any(lat > 90 | lat < -90)) { + stop("Parameter 'lat' must contain values within the range [-90, 90].") + } + if (!is.numeric(lon) | length(lon) != dim(ano)[space_dim[2]]) { + stop(paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.")) + } + if (all(lon >= 0)) { + if (any(lon > 360 | lon < 0)) { + stop("Parameter 'lon' must be within the range [-180, 180] or [0, 360].") + } + } else { + if (any(lon < -180 | lon > 180)) { + stop("Parameter 'lon' must be within the range [-180, 180] or [0, 360].") + } + } + stop_needed <- FALSE + # A preset region for computing EuroAtlantic teleconnections + lat.min <- 20 + lat.max <- 80 + lon.min <- -90 # Write this as a negative number please! + lon.max <- 60 + + # Choose lats and lons inside the Euroatlantic region. + # Change lon to [-180, 180] if it isn't + lon <- ifelse(lon < 180, lon, lon - 360) + ind_lat <- which(lat >= lat.min & lat <= lat.max) + ind_lon <- which(lon >= lon.min & lon <= lon.max) + + # Subset + lat <- lat[ind_lat] + lon <- lon[ind_lon] + + # Lat should be [20, 80] (5deg tolerance) + if (max(lat) < (lat.max - 5) | min(lat) > (lat.min + 5)) { + stop_needed <- TRUE + } + # Lon should be [-90, 60] (5deg tolerance) + if (!(min(lon) < (lon.min + 5) & max(lon) > (lon.max - 5))) { + stop_needed <- TRUE + } + if (stop_needed) { + stop("The provided data does not cover the EuroAtlantic region (20N-80N, 90W-60E).") + } + ## ntrunc + if (!is.numeric(ntrunc) | ntrunc %% 1 != 0 | ntrunc <= 0 | length(ntrunc) > 1) { + stop("Parameter 'ntrunc' must be a positive integer.") + } + ## corr + if (!is.logical(corr) | length(corr) > 1) { + stop("Parameter 'corr' 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 indices + + ano <- ClimProjDiags::Subset(ano, space_dim, list(ind_lat, ind_lon), drop = FALSE) + + # ntrunc is bounded + if (ntrunc != min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), ntrunc)) { + ntrunc <- min(dim(ano)[time_dim], prod(dim(ano)[space_dim]), ntrunc) + .warning(paste0("Parameter 'ntrunc' is changed to ", ntrunc, ", the minimum among ", + "the length of time_dim, the production of the length of space_dim, ", + "and ntrunc.")) + } + if (ntrunc < 4) { + .warning(paste0("Parameter 'ntrunc' is ", ntrunc, " so only the first ", ntrunc, + " modes will be calculated.")) + } + + # Area weighting is needed to compute the fraction of variance explained by + # each mode + space_ind <- sapply(space_dim, function(a) which(names(dim(ano)) == a)) + wght <- array(cos(lat * pi/180), dim = dim(ano)[space_ind]) + + # We want the covariance matrix to be weigthed by the grid + # cell area so the anoaly field is weighted by its square + # root since the covariance matrix equals transpose(ano) + # times ano. + wght <- sqrt(wght) + + reofs <- Apply(ano, + target_dims = c(time_dim, space_dim), + output_dims = list(REOFs = c('mode', space_dim), + RPCs = c(time_dim, 'mode'), + var = 'mode'), + fun = .REOF, + corr = corr, ntrunc = ntrunc, wght = wght, + ncores = ncores) + + if (ntrunc >= 4) { + TCP <- ClimProjDiags::Subset(reofs$REOFs, 'mode', 1:4, drop = FALSE) + TCI <- ClimProjDiags::Subset(reofs$RPCs, 'mode', 1:4, drop = FALSE) + } else { + TCP <- reofs$REOFs + TCI <- reofs$RPCs + } + + return(list(patterns = TCP, indices = TCI, var = reofs$var, wght = wght)) +} + diff --git a/R/REOF.R b/R/REOF.R index 2a32b8e..b6c953b 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -12,8 +12,8 @@ #'@param time_dim A character string indicating the name of the time dimension #' of 'ano'. The default value is 'sdate'. #'@param space_dim A vector of two character strings. The first is the dimension -#' name of longitude of 'ano' and the second is the dimension name of latitude -#' of 'ano'. The default value is c('lon', 'lat'). +#' name of latitude of 'ano' and the second is the dimension name of longitude +#' of 'ano'. The default value is c('lat', 'lon'). #'@param ntrunc A positive integer of the modes to be kept. The default value #' is 15. If time length or the product of latitude length and longitude #' length is less than ntrunc, ntrunc is equal to the minimum of the three @@ -27,24 +27,24 @@ #'A list containing: #'\item{REOFs}{ #' An array of REOF patterns normalized to 1 (unitless) with dimensions -#' (number of modes, rest of the dimensions of ano except 'time_dim'). -#' Multiplying 'REOFs' by 'RPCs' gives the original reconstructed -#' field. +#' (number of modes, the rest of the dimensions of 'ano' except +#' 'time_dim'). Multiplying 'REOFs' by 'RPCs' gives the original +#' reconstructed field. #'} #'\item{RPCs}{ #' An array of principal components with the units of the original field to -#' the power of 2, with dimensions (time_dim, number of modes, rest of the -#' dimensions except 'space_dim'). +#' the power of 2, with dimensions (time_dim, number of modes, the rest of the +#' dimensions of 'ano' except 'space_dim'). #'} #'\item{var}{ #' An array of the percentage (%) of variance fraction of total variance -#' explained by each mode. The dimensions are (number of modes, rest of the -#' dimension except 'time_dim' and 'space_dim'). +#' explained by each mode. The dimensions are (number of modes, the rest of +#' the dimension except 'time_dim' and 'space_dim'). #'} #'\item{wght}{ #' An array of the area weighting with dimensions 'space_dim'. It is calculated -#' by cosine of 'lat' and used to compute the fraction of variance explained by -#' each REOFs. +#' by the square root of cosine of 'lat' and used to compute the fraction of +#' variance explained by each REOFs. #'} #' #'@seealso EOF @@ -113,8 +113,14 @@ REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', stop(paste0("Parameter 'lon' must be a numeric vector with the same ", "length as the longitude dimension of 'ano'.")) } - if (any(lon > 360 | lon < -360)) { - warning("Some 'lon' is out of the range [-360, 360].") + if (all(lon >= 0)) { + if (any(lon > 360 | lon < 0)) { + stop("Parameter 'lon' must be within the range [-180, 180] or [0, 360].") + } + } else { + if (any(lon < -180 | lon > 180)) { + stop("Parameter 'lon' must be within the range [-180, 180] or [0, 360].") + } } ## ntrunc if (!is.numeric(ntrunc) | ntrunc %% 1 != 0 | ntrunc <= 0 | length(ntrunc) > 1) { diff --git a/man/EuroAtlanticTC.Rd b/man/EuroAtlanticTC.Rd new file mode 100644 index 0000000..6fa6aa3 --- /dev/null +++ b/man/EuroAtlanticTC.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/EuroAtlanticTC.R +\name{EuroAtlanticTC} +\alias{EuroAtlanticTC} +\title{Teleconnection indices in European Atlantic Ocean region} +\usage{ +EuroAtlanticTC( + ano, + lat, + lon, + ntrunc = 30, + time_dim = "sdate", + space_dim = c("lat", "lon"), + corr = FALSE, + ncores = NULL +) +} +\arguments{ +\item{ano}{A numerical array of anomalies with named dimensions to calculate +REOF then the four teleconnections. The dimensions must have at least +'time_dim' and 'space_dim', and the data should cover the European Atlantic +Ocean area (20N-80N, 90W-60E).} + +\item{lat}{A vector of the latitudes of 'ano'. It should be 20N-80N.} + +\item{lon}{A vector of the longitudes of 'ano'. It should be 90W-60E.} + +\item{ntrunc}{A positive integer of the modes to be kept. The default value +is 30. If time length or the product of latitude length and longitude +length is less than ntrunc, ntrunc is equal to the minimum of the three +values.} + +\item{time_dim}{A character string indicating the name of the time dimension +of 'ano'. The default value is 'sdate'.} + +\item{space_dim}{A vector of two character strings. The first is the dimension +name of latitude of 'ano' and the second is the dimension name of longitude +of 'ano'. The default value is c('lat', 'lon').} + +\item{corr}{A logical value indicating whether to base on a correlation (TRUE) +or on a covariance matrix (FALSE). The default value is FALSE.} + +\item{ncores}{An integer indicating the number of cores to use for parallel +computation. The default value is NULL.} +} +\value{ +A list containing: +\item{patterns}{ + An array of the first four REOF patterns normalized to 1 (unitless) with + dimensions (modes = 4, the rest of the dimensions of 'ano' except + 'time_dim'). Multiplying 'patterns' by 'indices' gives the original + reconstructed field. +} +\item{indices}{ + An array of the first four principal components with the units of the + original field to the power of 2, with dimensions (time_dim, modes = 4, the + rest of the dimensions of 'ano' except 'space_dim'). +} +\item{var}{ + An array of the percentage (%) of variance fraction of total variance + explained by each mode. The dimensions are (modes = ntrunc, the rest of the + dimensions of 'ano' except 'time_dim' and 'space_dim'). +} +\item{wght}{ + An array of the area weighting with dimensions 'space_dim'. It is calculated + by the square root of cosine of 'lat' and used to compute the fraction of + variance explained by each REOFs. +} +} +\description{ +Calculate the four main teleconnection indices in European Atlantic Ocean +region: North Atlantic oscillation (NAO), East Atlantic Pattern (EA), East +Atlantic/Western Russia (EAWR), and Scandinavian pattern (SCA). The function +\code{REOF()} is used for the calculation, and the first four modes are +returned. +} +\examples{ + +} +\seealso{ +REOF NAO +} diff --git a/man/REOF.Rd b/man/REOF.Rd index a65331c..ca5473b 100644 --- a/man/REOF.Rd +++ b/man/REOF.Rd @@ -32,8 +32,8 @@ values.} of 'ano'. The default value is 'sdate'.} \item{space_dim}{A vector of two character strings. The first is the dimension -name of longitude of 'ano' and the second is the dimension name of latitude -of 'ano'. The default value is c('lon', 'lat').} +name of latitude of 'ano' and the second is the dimension name of longitude +of 'ano'. The default value is c('lat', 'lon').} \item{corr}{A logical value indicating whether to base on a correlation (TRUE) or on a covariance matrix (FALSE). The default value is FALSE.} @@ -45,24 +45,24 @@ computation. The default value is NULL.} A list containing: \item{REOFs}{ An array of REOF patterns normalized to 1 (unitless) with dimensions - (number of modes, rest of the dimensions of ano except 'time_dim'). - Multiplying 'REOFs' by 'RPCs' gives the original reconstructed - field. + (number of modes, the rest of the dimensions of 'ano' except + 'time_dim'). Multiplying 'REOFs' by 'RPCs' gives the original + reconstructed field. } \item{RPCs}{ An array of principal components with the units of the original field to - the power of 2, with dimensions (time_dim, number of modes, rest of the - dimensions except 'space_dim'). + the power of 2, with dimensions (time_dim, number of modes, the rest of the + dimensions of 'ano' except 'space_dim'). } \item{var}{ An array of the percentage (%) of variance fraction of total variance - explained by each mode. The dimensions are (number of modes, rest of the - dimension except 'time_dim' and 'space_dim'). + explained by each mode. The dimensions are (number of modes, the rest of + the dimension except 'time_dim' and 'space_dim'). } \item{wght}{ An array of the area weighting with dimensions 'space_dim'. It is calculated - by cosine of 'lat' and used to compute the fraction of variance explained by - each REOFs. + by the square root of cosine of 'lat' and used to compute the fraction of + variance explained by each REOFs. } } \description{ diff --git a/tests/testthat/test-EuroAtlanticTC.R b/tests/testthat/test-EuroAtlanticTC.R new file mode 100644 index 0000000..0f73524 --- /dev/null +++ b/tests/testthat/test-EuroAtlanticTC.R @@ -0,0 +1,304 @@ +context("s2dv::EuroAtlanticTC tests") + +############################################## + # dat1 + set.seed(1) + dat1 <- array(rnorm(480), dim = c(sdate = 10, lat = 6, lon = 8)) + lat1 <- seq(20, 80, length.out = 6) + lon1 <- seq(-90, 60, length.out = 8) + + # dat2 + set.seed(2) + dat2 <- array(rnorm(800), dim = c(dat = 2, lat = 8, lon = 15, sdate = 5)) + lat2 <- seq(10, 90, length.out = 8) + lon2 <- seq(-100, 70, length.out = 15) + + # dat3 + set.seed(2) + dat3 <- array(rnorm(1520), dim = c(dat = 2, lat = 8, lon = 19, sdate = 5)) + lat3 <- seq(10, 90, length.out = 8) + lon3 <- c(seq(0, 70, length.out = 8), seq(250, 350, length.out = 11)) + +############################################## +test_that("1. Input checks", { + + # ano + expect_error( + EuroAtlanticTC(c()), + "Parameter 'ano' cannot be NULL." + ) + expect_error( + EuroAtlanticTC(c(NA, NA)), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + EuroAtlanticTC(list(a = array(rnorm(50), dim = c(dat = 5, sdate = 10)), b = c(1:4))), + "Parameter 'ano' must be a numeric array." + ) + expect_error( + EuroAtlanticTC(array(1:10, dim = c(2, 5))), + "Parameter 'ano' must have dimension names." + ) + # time_dim + expect_error( + EuroAtlanticTC(dat1, time_dim = 2), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + EuroAtlanticTC(dat1, time_dim = c('a','sdate')), + "Parameter 'time_dim' must be a character string." + ) + # space_dim + expect_error( + EuroAtlanticTC(dat1, space_dim = 'lat'), + "Parameter 'space_dim' must be a character vector of 2." + ) + expect_error( + EuroAtlanticTC(dat1, space_dim = c('latitude', 'longitude')), + "Parameter 'space_dim' is not found in 'ano' dimension." + ) + # lat and lon + expect_error( + EuroAtlanticTC(dat1, lat = 1:10), + paste0("Parameter 'lat' must be a numeric vector with the same ", + "length as the latitude dimension of 'ano'.") + ) + expect_error( + EuroAtlanticTC(dat1, lat = seq(-100, -80, length.out = 6)), + "Parameter 'lat' must contain values within the range \\[-90, 90\\]." + ) + expect_error( + EuroAtlanticTC(dat1, lat = lat1, lon = c('a', 'b')), + paste0("Parameter 'lon' must be a numeric vector with the same ", + "length as the longitude dimension of 'ano'.") + ) + expect_error( + EuroAtlanticTC(dat1, lat = lat1, lon = seq(300, 370, length.out = 8)), + "Parameter 'lon' must be within the range [-180, 180] or [0, 360].", + fixed = TRUE + ) + expect_error( + EuroAtlanticTC(dat1, lat = lat1, lon = seq(-190, -10, length.out = 8)), + "Parameter 'lon' must be within the range [-180, 180] or [0, 360].", + fixed = TRUE + ) + expect_error( + EuroAtlanticTC(dat1, lat = seq(30, 80, length.out = 6), lon = lon1), + "The provided data does not cover the EuroAtlantic region (20N-80N, 90W-60E).", + fixed = TRUE + ) + expect_error( + EuroAtlanticTC(dat1, lat = lat1, lon = seq(-80, 20, length.out = 8)), + "The provided data does not cover the EuroAtlantic region (20N-80N, 90W-60E).", + fixed = TRUE + ) + # ntrunc + expect_error( + EuroAtlanticTC(dat1, lat = lat1, lon = lon1, ntrunc = 0), + "Parameter 'ntrunc' must be a positive integer." + ) + # corr + expect_error( + EuroAtlanticTC(dat1, lat = lat1, lon = lon1, corr = 0.1), + "Parameter 'corr' must be one logical value." + ) + # ncores + expect_error( + EuroAtlanticTC(dat1, lat1, lon1, ncore = 3.5), + "Parameter 'ncores' must be a positive integer." + ) + +}) + +############################################## +test_that("2. dat1", { + + expect_equal( + names(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 4)), + c("patterns", "indices", "var", "wght") + ) + expect_equal( + dim(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 4)$patterns), + c(mode = 4, lat = 6, lon = 8) + ) + expect_equal( + dim(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$patterns), + c(mode = 4, lat = 6, lon = 8) + ) + expect_equal( + dim(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 9)$indices), + c(sdate = 10, mode = 4) + ) + expect_equal( + dim(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$var), + c(mode = 10) + ) + expect_equal( + dim(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 4)$wght), + c(lat = 6, lon = 8) + ) + expect_equal( + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 4)$patterns[, 2, 3], + c(-0.019905033, -0.048926441, -0.330219176, 0.008138493), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 5)$patterns[, 2, 3], + c(0.01878324, -0.03784923, -0.22820514, -0.21184373), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$indices[2, ], + c(-1.944509, -1.335159, 0.997195, -2.697545), + tolerance = 0.0001 + ) + expect_equal( + mean(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$var), + 10, + tolerance = 0.0001 + ) + expect_equal( + as.vector(EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$var[1:4]), + c(17.995853, 10.768974, 9.598904, 10.234672), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$wght[1,1], + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$wght[1,2] + ) + expect_equal( + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 10)$wght[1,1], + c(0.9693774), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("3. dat2", { + + expect_equal( + names(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 4)), + c("patterns", "indices", "var", "wght") + ) + expect_equal( + dim(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$patterns), + c(mode = 4, lat = 6, lon = 13, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 4)$patterns), + c(mode = 4, lat = 6, lon = 13, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$indices), + c(sdate = 5, mode = 4, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$var), + c(mode = 5, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 4)$wght), + c(lat = 6, lon = 13) + ) + expect_equal( + EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 4)$patterns[, 2, 3, 2], + c(-0.17289486, -0.07021256, -0.08045222, 0.17330862), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$patterns[, 2, 3, 1], + c(0.1347727, 0.2157945, -0.1024759, 0.1633547), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$indices[2, , 1], + c(2.1975962, 2.9158790, -3.2257169, -0.4055974), + tolerance = 0.0001 + ) + expect_equal( + mean(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$var), + 20, + tolerance = 0.0001 + ) + expect_equal( + as.vector(EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$var[1:4]), + c(23.06692, 21.98278, 20.22588, 19.51251), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$wght[1,1], + EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$wght[1,2] + ) + expect_equal( + EuroAtlanticTC(dat2, lon = lon2, lat = lat2, ntrunc = 5)$wght[1,1], + c(0.964818), + tolerance = 0.0001 + ) + +}) + +############################################## +test_that("4. dat3", { + + expect_equal( + names(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 4)), + c("patterns", "indices", "var", "wght") + ) + expect_equal( + dim(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$patterns), + c(mode = 4, lat = 6, lon = 16, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 4)$patterns), + c(mode = 4, lat = 6, lon = 16, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$indices), + c(sdate = 5, mode = 4, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$var), + c(mode = 5, dat = 2) + ) + expect_equal( + dim(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 4)$wght), + c(lat = 6, lon = 16) + ) + expect_equal( + EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 4)$patterns[, 2, 3, 2], + c(-0.10653582, -0.22437848, 0.10192633, 0.08331549), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$patterns[, 2, 3, 1], + c(0.25209479, -0.05872688, 0.03186457, -0.02901076), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$indices[2, , 1], + c(2.940060, 5.036896, 4.188896, 2.816158), + tolerance = 0.0001 + ) + expect_equal( + mean(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$var), + 20, + tolerance = 0.0001 + ) + expect_equal( + as.vector(EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$var[1:4]), + c(24.38583, 22.57439, 20.19659, 17.95064), + tolerance = 0.0001 + ) + expect_equal( + EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$wght[1,1], + EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$wght[1,2] + ) + expect_equal( + EuroAtlanticTC(dat3, lon = lon3, lat = lat3, ntrunc = 5)$wght[1,1], + c(0.964818), + tolerance = 0.0001 + ) + +}) + diff --git a/tests/testthat/test-REOF.R b/tests/testthat/test-REOF.R index c109d38..9f4bb48 100644 --- a/tests/testthat/test-REOF.R +++ b/tests/testthat/test-REOF.R @@ -67,9 +67,10 @@ test_that("1. Input checks", { paste0("Parameter 'lon' must be a numeric vector with the same ", "length as the longitude dimension of 'ano'.") ) - expect_warning( + expect_error( REOF(dat1, lat = lat1, lon = c(350, 370)), - "Some 'lon' is out of the range \\[-360, 360\\]." + "Parameter 'lon' must be within the range [-180, 180] or [0, 360].", + fixed = TRUE ) # ntrunc expect_error( -- GitLab From 844efc9ae0b231435fe9410bc56365d0b2c5d85e Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 18 May 2021 13:59:01 +0200 Subject: [PATCH 24/28] Add example --- R/EuroAtlanticTC.R | 10 ++++++++-- man/EuroAtlanticTC.Rd | 10 ++++++++-- tests/testthat/test-EuroAtlanticTC.R | 6 +++++- 3 files changed, 21 insertions(+), 5 deletions(-) diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R index 1d2c143..9a61e76 100644 --- a/R/EuroAtlanticTC.R +++ b/R/EuroAtlanticTC.R @@ -31,8 +31,8 @@ #'\item{patterns}{ #' An array of the first four REOF patterns normalized to 1 (unitless) with #' dimensions (modes = 4, the rest of the dimensions of 'ano' except -#' 'time_dim'). Multiplying 'patterns' by 'indices' gives the original -#' reconstructed field. +#' 'time_dim'). The modes represent NAO, EA, EAWR, and SCA in order. +#' Multiplying 'patterns' by 'indices' gives the original reconstructed field. #'} #'\item{indices}{ #' An array of the first four principal components with the units of the @@ -50,6 +50,12 @@ #' variance explained by each REOFs. #'} #'@examples +#'# Use synthetic data +#'set.seed(1) +#'dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15) +#'lat <- seq(10, 90, length.out = 8) +#'lon <- seq(-100, 70, length.out = 15) +#'res <- EuroAtlanticTC(ano, lat = lat, lon = lon) #' #'@seealso REOF NAO #'@import multiApply diff --git a/man/EuroAtlanticTC.Rd b/man/EuroAtlanticTC.Rd index 6fa6aa3..7fe1ee4 100644 --- a/man/EuroAtlanticTC.Rd +++ b/man/EuroAtlanticTC.Rd @@ -48,8 +48,8 @@ A list containing: \item{patterns}{ An array of the first four REOF patterns normalized to 1 (unitless) with dimensions (modes = 4, the rest of the dimensions of 'ano' except - 'time_dim'). Multiplying 'patterns' by 'indices' gives the original - reconstructed field. + 'time_dim'). The modes represent NAO, EA, EAWR, and SCA in order. + Multiplying 'patterns' by 'indices' gives the original reconstructed field. } \item{indices}{ An array of the first four principal components with the units of the @@ -75,6 +75,12 @@ Atlantic/Western Russia (EAWR), and Scandinavian pattern (SCA). The function returned. } \examples{ +# Use synthetic data +set.seed(1) +dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15) +lat <- seq(10, 90, length.out = 8) +lon <- seq(-100, 70, length.out = 15) +res <- EuroAtlanticTC(ano, lat = lat, lon = lon) } \seealso{ diff --git a/tests/testthat/test-EuroAtlanticTC.R b/tests/testthat/test-EuroAtlanticTC.R index 0f73524..6e3ac4b 100644 --- a/tests/testthat/test-EuroAtlanticTC.R +++ b/tests/testthat/test-EuroAtlanticTC.R @@ -171,7 +171,11 @@ test_that("2. dat1", { c(0.9693774), tolerance = 0.0001 ) - + expect_equal( + EuroAtlanticTC(dat1, lon = lon1, lat = lat1, ntrunc = 4, corr = T)$patterns[, 2, 3], + c(-0.05850999, 0.03827591, -0.04454523, -0.43713946), + tolerance = 0.0001 + ) }) ############################################## -- GitLab From b0b0b60e40c92c3ad9e998a6b61eae51c75a5a48 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 18 May 2021 14:31:43 +0200 Subject: [PATCH 25/28] Allow EuroAtlanticTC to be ProjectField's eof input --- R/EuroAtlanticTC.R | 2 +- R/ProjectField.R | 11 ++++++---- man/EuroAtlanticTC.Rd | 2 +- man/ProjectField.Rd | 5 +++-- tests/testthat/test-ProjectField.R | 34 ++++++++++++++++++++++++++++-- 5 files changed, 44 insertions(+), 10 deletions(-) diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R index 9a61e76..b275520 100644 --- a/R/EuroAtlanticTC.R +++ b/R/EuroAtlanticTC.R @@ -52,7 +52,7 @@ #'@examples #'# Use synthetic data #'set.seed(1) -#'dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15) +#'dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15)) #'lat <- seq(10, 90, length.out = 8) #'lon <- seq(-100, 70, length.out = 15) #'res <- EuroAtlanticTC(ano, lat = lat, lon = lon) diff --git a/R/ProjectField.R b/R/ProjectField.R index 7432632..309f3ef 100644 --- a/R/ProjectField.R +++ b/R/ProjectField.R @@ -2,8 +2,9 @@ #' #'Project anomalies onto modes of variability to get the temporal evolution of #'the EOF mode selected. It returns principal components (PCs) by area-weighted -#'projection onto EOF pattern (from \code{EOF()} or \code{REOF()}). The -#'calculation removes NA and returns NA if the whole spatial pattern is NA. +#'projection onto EOF pattern (from \code{EOF()}) or REOF pattern (from +#'\code{REOF()} or \code{EuroAtlanticTC()}). The calculation removes NA and +#'returns NA if the whole spatial pattern is NA. #' #'@param ano A numerical array of anomalies with named dimensions. The #' dimensions must have at least 'time_dim' and 'space_dim'. It can be @@ -84,9 +85,11 @@ ProjectField <- function(ano, eof, time_dim = 'sdate', space_dim = c('lat', 'lon EOFs <- "EOFs" } else if ('REOFs' %in% names(eof)) { EOFs <- "REOFs" + } else if ('patterns' %in% names(eof)) { + EOFs <- "patterns" } else { - stop(paste0("Parameter 'eof' must be a list that contains 'EOFs' or 'REOFs'. ", - "It can be generated by EOF() or REOF().")) + stop(paste0("Parameter 'eof' must be a list that contains 'EOFs', 'REOFs', ", + "or 'patterns'. It can be generated by EOF(), REOF(), or EuroAtlanticTC().")) } if (!'wght' %in% names(eof)) { stop(paste0("Parameter 'eof' must be a list that contains 'wght'. ", diff --git a/man/EuroAtlanticTC.Rd b/man/EuroAtlanticTC.Rd index 7fe1ee4..edeee54 100644 --- a/man/EuroAtlanticTC.Rd +++ b/man/EuroAtlanticTC.Rd @@ -77,7 +77,7 @@ returned. \examples{ # Use synthetic data set.seed(1) -dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15) +dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15)) lat <- seq(10, 90, length.out = 8) lon <- seq(-100, 70, length.out = 15) res <- EuroAtlanticTC(ano, lat = lat, lon = lon) diff --git a/man/ProjectField.Rd b/man/ProjectField.Rd index 1b3833f..358f4ee 100644 --- a/man/ProjectField.Rd +++ b/man/ProjectField.Rd @@ -44,8 +44,9 @@ A numerical array of the principal components in the verification \description{ Project anomalies onto modes of variability to get the temporal evolution of the EOF mode selected. It returns principal components (PCs) by area-weighted -projection onto EOF pattern (from \code{EOF()} or \code{REOF()}). The -calculation removes NA and returns NA if the whole spatial pattern is NA. +projection onto EOF pattern (from \code{EOF()}) or REOF pattern (from +\code{REOF()} or \code{EuroAtlanticTC()}). The calculation removes NA and +returns NA if the whole spatial pattern is NA. } \examples{ \dontshow{ diff --git a/tests/testthat/test-ProjectField.R b/tests/testthat/test-ProjectField.R index 5e0fca6..f3f05ce 100644 --- a/tests/testthat/test-ProjectField.R +++ b/tests/testthat/test-ProjectField.R @@ -43,6 +43,13 @@ context("s2dv::ProjectField tests") tmp <- array(rnorm(72), dim = c(sdate = 6, lat = 4, lon = 3)) eof5 <- EOF(tmp, lat5, lon5, neofs = 6) + # dat6 + set.seed(1) + dat6 <- array(rnorm(480), dim = c(sdate = 10, lat = 6, lon = 8)) + lat6 <- seq(20, 80, length.out = 6) + lon6 <- seq(-90, 60, length.out = 8) + reof6 <- EuroAtlanticTC(dat6, lat6, lon6, ntrunc = 10) + ############################################## test_that("1. Input checks", { @@ -75,8 +82,8 @@ test_that("1. Input checks", { ) expect_error( ProjectField(dat1, list(a = 1)), - paste0("Parameter 'eof' must be a list that contains 'EOFs' or 'REOFs'. ", - "It can be generated by EOF() or REOF()."), + paste0("Parameter 'eof' must be a list that contains 'EOFs', 'REOFs', ", + "or 'patterns'. It can be generated by EOF(), REOF(), or EuroAtlanticTC()."), fixed = TRUE ) eof_fake <- list(EOFs = 'a', wght = 1:10) @@ -271,3 +278,26 @@ test_that("6. dat5", { ) }) +############################################## +test_that("7. dat6", { + expect_equal( + dim(ProjectField(dat6, reof6, mode = 1)), + c(sdate = 10) + ) + expect_equal( + dim(ProjectField(dat6, reof6)), + c(mode = 4, sdate = 10) + ) + expect_equal( + mean(ProjectField(dat6, reof6)), + 0.3080207, + tolerance = 0.0001 + ) + expect_equal( + as.vector(ProjectField(dat6, reof6)[, 1]), + c(4.6114959, 0.8241051, 1.4160364, -0.9601872), + tolerance = 0.0001 + ) + +}) + -- GitLab From 5c6d6c0bfd455f00cd98131538452a6e5dcc7ca8 Mon Sep 17 00:00:00 2001 From: aho Date: Tue, 18 May 2021 14:43:33 +0200 Subject: [PATCH 26/28] Fix document --- NAMESPACE | 1 + R/EuroAtlanticTC.R | 2 +- R/REOF.R | 1 + man/EuroAtlanticTC.Rd | 2 +- 4 files changed, 4 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 94af45c..3b71241 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -112,4 +112,5 @@ importFrom(stats,rnorm) importFrom(stats,sd) importFrom(stats,setNames) importFrom(stats,ts) +importFrom(stats,varimax) importFrom(stats,window) diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R index b275520..f35278c 100644 --- a/R/EuroAtlanticTC.R +++ b/R/EuroAtlanticTC.R @@ -55,7 +55,7 @@ #'dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15)) #'lat <- seq(10, 90, length.out = 8) #'lon <- seq(-100, 70, length.out = 15) -#'res <- EuroAtlanticTC(ano, lat = lat, lon = lon) +#'res <- EuroAtlanticTC(dat, lat = lat, lon = lon) #' #'@seealso REOF NAO #'@import multiApply diff --git a/R/REOF.R b/R/REOF.R index b6c953b..7e6e510 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -71,6 +71,7 @@ #'} #' #'@import multiApply +#'@importFrom stats varimax #'@export REOF <- function(ano, lat, lon, ntrunc = 15, time_dim = 'sdate', space_dim = c('lat', 'lon'), corr = FALSE, ncores = NULL) { diff --git a/man/EuroAtlanticTC.Rd b/man/EuroAtlanticTC.Rd index edeee54..16c90fe 100644 --- a/man/EuroAtlanticTC.Rd +++ b/man/EuroAtlanticTC.Rd @@ -80,7 +80,7 @@ set.seed(1) dat <- array(rnorm(800), dim = c(dat = 2, sdate = 5, lat = 8, lon = 15)) lat <- seq(10, 90, length.out = 8) lon <- seq(-100, 70, length.out = 15) -res <- EuroAtlanticTC(ano, lat = lat, lon = lon) +res <- EuroAtlanticTC(dat, lat = lat, lon = lon) } \seealso{ -- GitLab From 59dce48f22ac23a12b8011e208061df243256f11 Mon Sep 17 00:00:00 2001 From: aho Date: Thu, 27 May 2021 14:23:11 +0200 Subject: [PATCH 27/28] Revise documentation for ntrunc --- R/REOF.R | 9 +++++---- man/REOF.Rd | 9 +++++---- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/R/REOF.R b/R/REOF.R index 7e6e510..c9c82cf 100644 --- a/R/REOF.R +++ b/R/REOF.R @@ -14,10 +14,11 @@ #'@param space_dim A vector of two character strings. The first is the dimension #' name of latitude of 'ano' and the second is the dimension name of longitude #' of 'ano'. The default value is c('lat', 'lon'). -#'@param ntrunc A positive integer of the modes to be kept. The default value -#' is 15. If time length or the product of latitude length and longitude -#' length is less than ntrunc, ntrunc is equal to the minimum of the three -#' values. +#'@param ntrunc A positive integer of the number of eofs to be kept for varimax +#' rotation. This function uses this value as 'neof' too, which is the number +#' of eofs to return by \code{.EOF()}. The default value is 15. If time length +#' or the product of latitude length and longitude length is less than +#' 'ntrunc', 'ntrunc' is equal to the minimum of the three values. #'@param corr A logical value indicating whether to base on a correlation (TRUE) #' or on a covariance matrix (FALSE). The default value is FALSE. #'@param ncores An integer indicating the number of cores to use for parallel diff --git a/man/REOF.Rd b/man/REOF.Rd index ca5473b..a5d416c 100644 --- a/man/REOF.Rd +++ b/man/REOF.Rd @@ -23,10 +23,11 @@ REOF. The dimensions must have at least 'time_dim' and 'space_dim'.} \item{lon}{A vector of the longitudes of 'ano'.} -\item{ntrunc}{A positive integer of the modes to be kept. The default value -is 15. If time length or the product of latitude length and longitude -length is less than ntrunc, ntrunc is equal to the minimum of the three -values.} +\item{ntrunc}{A positive integer of the number of eofs to be kept for varimax +rotation. This function uses this value as 'neof' too, which is the number +of eofs to return by \code{.EOF()}. The default value is 15. If time length +or the product of latitude length and longitude length is less than +'ntrunc', 'ntrunc' is equal to the minimum of the three values.} \item{time_dim}{A character string indicating the name of the time dimension of 'ano'. The default value is 'sdate'.} -- GitLab From 3dd72e4b0753ccba716b3164e36f00521dfd5fb6 Mon Sep 17 00:00:00 2001 From: aho Date: Mon, 7 Jun 2021 11:33:46 +0200 Subject: [PATCH 28/28] Correct the documentation of output --- R/EuroAtlanticTC.R | 6 ++++-- man/EuroAtlanticTC.Rd | 6 ++++-- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/R/EuroAtlanticTC.R b/R/EuroAtlanticTC.R index f35278c..2860a53 100644 --- a/R/EuroAtlanticTC.R +++ b/R/EuroAtlanticTC.R @@ -31,8 +31,10 @@ #'\item{patterns}{ #' An array of the first four REOF patterns normalized to 1 (unitless) with #' dimensions (modes = 4, the rest of the dimensions of 'ano' except -#' 'time_dim'). The modes represent NAO, EA, EAWR, and SCA in order. -#' Multiplying 'patterns' by 'indices' gives the original reconstructed field. +#' 'time_dim'). The modes represent NAO, EA, EAWR, and SCA, of which the order +#' and sign changes depending on the dataset and period employed, so manual +#' reordering may be needed. Multiplying 'patterns' by 'indices' gives the +#' original reconstructed field. #'} #'\item{indices}{ #' An array of the first four principal components with the units of the diff --git a/man/EuroAtlanticTC.Rd b/man/EuroAtlanticTC.Rd index 16c90fe..7f81b24 100644 --- a/man/EuroAtlanticTC.Rd +++ b/man/EuroAtlanticTC.Rd @@ -48,8 +48,10 @@ A list containing: \item{patterns}{ An array of the first four REOF patterns normalized to 1 (unitless) with dimensions (modes = 4, the rest of the dimensions of 'ano' except - 'time_dim'). The modes represent NAO, EA, EAWR, and SCA in order. - Multiplying 'patterns' by 'indices' gives the original reconstructed field. + 'time_dim'). The modes represent NAO, EA, EAWR, and SCA, of which the order + and sign changes depending on the dataset and period employed, so manual + reordering may be needed. Multiplying 'patterns' by 'indices' gives the + original reconstructed field. } \item{indices}{ An array of the first four principal components with the units of the -- GitLab