diff --git a/.Rbuildignore b/.Rbuildignore index c0e2736124c33fe6ccadcad4604bb76ac738da0f..83f840f062b3f6d4dcdc548e6458946c58f1bf70 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,5 +1,6 @@ .*\.git$ .*\.gitignore$ +.*\.gitlab$ .*\.tar.gz$ .*\.pdf$ ./.nc$ diff --git a/.gitlab/.gitkeep b/.gitlab/.gitkeep new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/.gitlab/issue_templates/.gitkeep b/.gitlab/issue_templates/.gitkeep new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/.gitlab/issue_templates/default.md b/.gitlab/issue_templates/default.md new file mode 100644 index 0000000000000000000000000000000000000000..a430b52efade19b3250281c10dab329856b77356 --- /dev/null +++ b/.gitlab/issue_templates/default.md @@ -0,0 +1,25 @@ +(This is a template to report errors and bugs. Please fill in the relevant information and delete the rest.) + +Hi @erifarov (and @aho), + +#### R and packages version +(Which R version are you using? ex. 4.1.2) +(Which R packages versions are you using? use sessionInfo(). ex. CSIndicators_1.0.1, CSTools_5.0.1 ...) +(Which machine are you using? WS, Nord3, other...) + +#### Summary +(Bug: Summarize the bug and explain briefly the expected and the current behavior.) +(New development: Summarize the development needed.) + +#### Example +(Bug: Provide a **minimal reproducible example** and the error message.) +(New development: Provide an example script or useful piece of code if needed.) + +``` +Example: +[ERROR!]: Something went really wrong! +This is the error message that showed up on the terminal. +``` + +#### Other Relevant Information +(Additional information.) diff --git a/DESCRIPTION b/DESCRIPTION index 90e0e83155393c8d19d68ea8c92b9c0121f6153f..98fecac842870eb8bc56bcfb6379228bf67f9314 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: CSIndicators Title: Climate Services' Indicators Based on Sub-Seasonal to Decadal Predictions -Version: 1.0.1 +Version: 1.1.0 Authors@R: c( person("Eva", "Rifà", , "eva.rifarovira@bsc.es", role = c("cre")), person("Nuria", "Perez-Zanon", , "nuria.perez@bsc.es", role = c("aut"), comment = c(ORCID = "0000-0001-8568-3071")), @@ -16,21 +16,29 @@ Description: Set of generalised tools for the flexible computation of climate mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate - service application (agriculture, food security, energy, water management…). + service application (agriculture, food security, energy, water management, ...). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with 'CSTools'. - This package was developed in the context of H2020 MED-GOLD (776467) and - S2S4E (776787) projects. Lledó et al. (2019) . + This package is described in 'Pérez-Zanón et al. (2023) + ' and it was developed in the context of + 'H2020 MED-GOLD' (776467) and 'S2S4E' (776787) projects. See 'Lledó et al. (2019) + ' and 'Chou et al., 2023 + ' for details. Depends: R (>= 3.6.0) Imports: multiApply (>= 2.1.1), - stats + stats, + ClimProjDiags, + CSTools, + SPEI, + lmom, + lmomco, + zoo Suggests: testthat, - CSTools, knitr, markdown, rmarkdown @@ -40,3 +48,4 @@ URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 RoxygenNote: 7.2.0 +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index d80accbbe3b6781acb27cb8c953a9c6b00a1824a..bab43edcccecb70f92ef63df66c81e870745ec26 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,7 +6,12 @@ export(CST_AbsToProbs) export(CST_AccumulationExceedingThreshold) export(CST_MergeRefToExp) export(CST_PeriodAccumulation) +export(CST_PeriodMax) export(CST_PeriodMean) +export(CST_PeriodMin) +export(CST_PeriodPET) +export(CST_PeriodStandardization) +export(CST_PeriodVariance) export(CST_QThreshold) export(CST_SelectPeriodOnData) export(CST_Threshold) @@ -16,7 +21,12 @@ export(CST_WindCapacityFactor) export(CST_WindPowerDensity) export(MergeRefToExp) export(PeriodAccumulation) +export(PeriodMax) export(PeriodMean) +export(PeriodMin) +export(PeriodPET) +export(PeriodStandardization) +export(PeriodVariance) export(QThreshold) export(SelectPeriodOnData) export(SelectPeriodOnDates) @@ -26,7 +36,29 @@ export(TotalTimeExceedingThreshold) export(WindCapacityFactor) export(WindPowerDensity) import(multiApply) +importFrom(CSTools,s2dv_cube) +importFrom(ClimProjDiags,Subset) +importFrom(SPEI,hargreaves) +importFrom(SPEI,parglo.maxlik) +importFrom(SPEI,thornthwaite) +importFrom(lmom,cdfgam) +importFrom(lmom,cdfglo) +importFrom(lmom,cdfpe3) +importFrom(lmom,pelgam) +importFrom(lmom,pelglo) +importFrom(lmom,pelpe3) +importFrom(lmomco,are.lmom.valid) +importFrom(lmomco,pargam) +importFrom(lmomco,parglo) +importFrom(lmomco,parpe3) +importFrom(lmomco,pwm.pp) +importFrom(lmomco,pwm.ub) +importFrom(lmomco,pwm2lmom) importFrom(stats,approxfun) importFrom(stats,ecdf) +importFrom(stats,qnorm) importFrom(stats,quantile) +importFrom(stats,sd) +importFrom(stats,window) importFrom(utils,read.delim) +importFrom(zoo,rollapply) diff --git a/NEWS.md b/NEWS.md index 44285d2f5c49d8a63ca79ed8ce235d6ee3c1dacd..c3047f968328c38145628e7111e5cdcb9a0d5d8c 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,19 +1,40 @@ +# CSIndicators 1.1.0 (Release date: 2023-11-20) + +### Fixes +- Improve CST_PeriodMean() and CST_PeriodAccumulation() in order that Dates from the s2dv_cube reflect time aggregation. +- Correct output coordinates consistency (coords element) in CST functions +- Include again ClimProjDiags and s2dv dependency due to a dependency issue with an external package. +- Change default value of time_dim to be 'time' in all the function. +- Improve documentation of function MergeRefToExp mentioned the method used. + +### New features +- New functions to compute SPEI: PeriodPET, PeriodAccumulation with rolling accumulation and PeriodStandardization. +- New functions to compute bioclimatic indicators: PeriodMax, PeriodMin and PeriodVariance. +- Add 'memb_dim' parameter to MergeRefToExp. +- Add reference and improve documentation in MergeRefToExp. +- Substitute CST_Load by CST_Start in vignettes. +- Include new publication in documentation. +- Change to testthat edition 3. + # CSIndicators 1.0.1 (Release date: 2023-05-18) -**Fixes** + +### Fixes - Add EnergyIndicators vignette figures - Remove ClimProjDiags dependency - Remove s2dv dependency -# CSIndicators 1.0.0 (Release date: 2023-04-05) -**Fixes** +# CSIndicators 1.0.0 (Release date: 2023-04-05) + +### Fixes - Correct vignettes figures links. -**New features** +### New features - Exceeding Threshold functions to allow between thresholds or equal threshold options. - New s2dv_cube object development for all the functions, unit tests, examples and vignettes. # CSIndicators 0.0.2 (Release date: 2022-10-21) -**Fixes** + +### Fixes - Correct figures of EnergyIndicators vignette. - Sanity check correction in functions CST_PeriodAccumulation, CST_AbsToProbs, CST_AccumulationExceedingThreshold, CST_MergeRefToExp, CST_PeriodMean, CST_QThreshold, CST_SelectPeriodOnData, CST_Threshold, TotalSpellTimeExceedingThreshold, CST_TotalTimeExceedingThreshold, CST_WindCapacityFactor and CST_WindPowerDensity. - Revise examples using s2dv::InsertDim in MergeRefToExp(). diff --git a/R/AbsToProbs.R b/R/AbsToProbs.R index e086e6e429e92615bf9300d5d22bffd083ae7bd7..db8891ea5b9ded36537da1686af149b452872223 100644 --- a/R/AbsToProbs.R +++ b/R/AbsToProbs.R @@ -5,8 +5,8 @@ #'(start dates) are provided, the function will create the Cumulative #'Distribution Function excluding the corresponding initialization. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to define the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -17,7 +17,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -33,24 +33,24 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#' time = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_AbsToProbs(exp) #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +#'dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) #'exp_probs <- CST_AbsToProbs(data = exp, start = list(21, 4), end = list(21, 6)) #'@import multiApply #'@importFrom stats ecdf #'@export CST_AbsToProbs <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -102,7 +102,7 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -118,17 +118,17 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #' #'@examples #'exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#' time = 9, lat = 2, lon = 2)) #'exp_probs <- AbsToProbs(exp) #'data <- array(rnorm(5 * 3 * 61 * 1), -#' c(member = 5, sdate = 3, ftime = 61, lon = 1)) +#' c(member = 5, sdate = 3, time = 61, lon = 1)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-06-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 61, sdate = 3) +#'dim(Dates) <- c(time = 61, sdate = 3) #'exp_probs <- AbsToProbs(data, dates = Dates, start = list(21, 4), #' end = list(21, 6)) #' @@ -136,7 +136,7 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #'@importFrom stats ecdf #'@export AbsToProbs <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # data if (!is.numeric(data)) { diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index e346b5310504a9e0a9b0fbbf289d332d4cbeb8cb..b8ae9ae798909c22d8a9ee4b4804ed09af63ac0c 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -8,12 +8,12 @@ #'following agriculture indices for heat stress can be obtained by using this #'function: #'\itemize{ -#' \item\code{GDD}{Summation of daily differences between daily average -#' temperatures and 10°C between April 1st and October 31st} +#' \item{'GDD', Summation of daily differences between daily average +#' temperatures and 10°C between April 1st and October 31st.} #'} #' -#'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold If only one threshold is used, it can be an 's2dv_cube' #' object or a multidimensional array with named dimensions. It must be in the #' same units and with the common dimensions of the same length as parameter @@ -40,7 +40,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) #' or not (FALSE). @@ -49,18 +49,35 @@ #' #'@return An 's2dv_cube' object containing the aggregated values in the element #'\code{data} with dimensions of the input parameter 'data' except the dimension -#'where the indicator has been computed. +#'where the indicator has been computed. The 'Dates' array is updated to +#'the dates corresponding to the beginning of the aggregated time period. A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, -#' ftime = 9, lat = 2, lon = 2)) +#'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'class(exp) <- 's2dv_cube' -#'DOT <- CST_AccumulationExceedingThreshold(exp, threshold = 280) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#'exp$attrs$Dates <- Dates +#'AT <- CST_AccumulationExceedingThreshold(data = exp, threshold = 100, +#' start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, - start = NULL, end = NULL, time_dim = 'ftime', + start = NULL, end = NULL, time_dim = 'time', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -78,7 +95,7 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = if (length(op) == 1) { if (inherits(threshold, 's2dv_cube')) { - threshold <- threshold$data + threshold <- threshold$data } } else if (length(op) == 2) { if (inherits(threshold[[1]], 's2dv_cube')) { @@ -89,17 +106,39 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = } } - total <- AccumulationExceedingThreshold(data$data, dates = data$attrs$Dates, + Dates <- data$attrs$Dates + total <- AccumulationExceedingThreshold(data = data$data, dates = Dates, threshold = threshold, op = op, diff = diff, start = start, end = end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } + return(data) } #'Accumulation of a variable when Exceeding (not exceeding) a Threshold @@ -112,8 +151,8 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'following agriculture indices for heat stress can be obtained by using this #'function: #'\itemize{ -#' \item\code{GDD}{Summation of daily differences between daily average -#' temperatures and 10°C between April 1st and October 31st} +#' \item{'GDD', Summation of daily differences between daily average +#' temperatures and 10°C between April 1st and October 31st.} #'} #' #'@param data A multidimensional array with named dimensions. @@ -133,9 +172,9 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'@param diff A logical value indicating whether to accumulate the difference #' between data and threshold (TRUE) or not (FALSE by default). It can only be #' TRUE if a unique threshold is used. -#'@param dates A vector of dates or a multidimensional array with of dates with -#' named dimensions matching the dimensions on parameter 'data'. By default it -#' is NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to define the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is @@ -146,7 +185,7 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) #' or not (FALSE). @@ -160,20 +199,14 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = #'@examples #'# Assuming data is already (tasmax + tasmin)/2 - 10 #'data <- array(rnorm(5 * 3 * 214 * 2, mean = 25, sd = 3), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), -#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), -#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), -#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), #' end = list(31, 10)) #'@import multiApply #'@export AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # data if (is.null(data)) { @@ -228,8 +261,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL } if (length(op) == 2) { if (length(op) != length(threshold)) { - stop(paste0("If 'op' is a pair of logical operators parameter 'threshold' ", - "also has to be a pair of values.")) + stop("If 'op' is a pair of logical operators parameter 'threshold' ", + "also has to be a pair of values.") } if (!is.numeric(threshold[[1]]) | !is.numeric(threshold[[2]])) { stop("Parameter 'threshold' must be numeric.") @@ -240,7 +273,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (!is.array(threshold[[1]]) && length(threshold[[1]]) > 1) { if (dim(data)[time_dim] != length(threshold[[1]])) { - stop("If parameter 'threshold' is a vector it must have the same length as data any time dimension.") + stop("If parameter 'threshold' is a vector it must have the same ", + "length as data any time dimension.") } else { dim(threshold[[1]]) <- length(threshold[[1]]) dim(threshold[[2]]) <- length(threshold[[2]]) @@ -265,8 +299,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (any(names(dim(threshold[[1]])) %in% names(dim(data)))) { common_dims <- dim(threshold[[1]])[names(dim(threshold[[1]])) %in% names(dim(data))] if (!all(common_dims == dim(data)[names(common_dims)])) { - stop(paste0("Parameter 'data' and 'threshold' must have same length of ", - "all common dimensions.")) + stop("Parameter 'data' and 'threshold' must have same length of ", + "all common dimensions.") } } } else if (length(threshold[[1]]) == 1) { @@ -276,7 +310,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL } else { if (!is.array(threshold) && length(threshold) > 1) { if (dim(data)[time_dim] != length(threshold)) { - stop("If parameter 'threshold' is a vector it must have the same length as data time dimension.") + stop("If parameter 'threshold' is a vector it must have the same ", + "length as data time dimension.") } else { dim(threshold) <- length(threshold) names(dim(threshold)) <- time_dim @@ -288,8 +323,8 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (any(names(dim(threshold)) %in% names(dim(data)))) { common_dims <- dim(threshold)[names(dim(threshold)) %in% names(dim(data))] if (!all(common_dims == dim(data)[names(common_dims)])) { - stop(paste0("Parameter 'data' and 'threshold' must have same length of ", - "all common dimensions.")) + stop("Parameter 'data' and 'threshold' must have same length of ", + "all common dimensions.") } } } else if (length(threshold) == 1) { @@ -313,27 +348,41 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL if (length(op) == 1) { if (time_dim %in% names(dim(threshold))) { if (dim(threshold)[time_dim] == dim(data)[time_dim]) { - threshold <- SelectPeriodOnData(threshold, dates, start, end, - time_dim = time_dim, ncores = ncores) + threshold <- SelectPeriodOnData(data = threshold, dates = dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } } } else if (length(op) == 2) { if (time_dim %in% names(dim(threshold[[1]]))) { if (dim(threshold[[1]])[time_dim] == dim(data)[time_dim]) { - threshold[[1]] <- SelectPeriodOnData(threshold[[1]], dates, start, end, - time_dim = time_dim, ncores = ncores) - threshold[[2]] <- SelectPeriodOnData(threshold[[2]], dates, start, end, - time_dim = time_dim, ncores = ncores) + threshold[[1]] <- SelectPeriodOnData(data = threshold[[1]], + dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + threshold[[2]] <- SelectPeriodOnData(data = threshold[[2]], dates = dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } } } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } } # diff if (length(op) == 2 & diff == TRUE) { - stop("Parameter 'diff' can't be TRUE if the parameter 'threshold' is a range of values.") + stop("Parameter 'diff' can't be TRUE if the parameter 'threshold' is a ", + "range of values.") } else if (diff == TRUE) { if (length(threshold) != 1) { stop("Parameter 'diff' can't be TRUE if the parameter 'threshold' is not a scalar.") @@ -345,8 +394,6 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FAL threshold <- 0 } - ### - if (length(op) > 1) { thres1 <- threshold[[1]] thres2 <- threshold[[2]] diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 434cae35c0db9d2d0312c02473a0b5a8ef490078..6d9fd6e88104d58c871254ac52171b4e4fce115d 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -3,143 +3,223 @@ #'Some indicators are defined for specific temporal periods (e.g.: summer from #'June 21st to September 21st). If the initialization forecast date is later #'than the one required for the indicator (e.g.: July 1st), the user may want to -#'merge past observations, or other references, to the forecast (or hindcast) -#'to compute the indicator. The function \code{MergeObs2Exp} takes care of this -#'steps. If the forecast simulation doesn't cover the required period because it -#'is initialized too early (e.g.: Initialization on November 1st the forecast -#'covers until the beginning of June next year), a climatology (or other -#'references) could be added at the end of the forecast lead time to cover the -#'desired period (e.g.: until the end of summer). +#'merge past observations, or other references, to the forecast (or hindcast) to +#'compute the indicator. If the forecast simulation doesn't cover the required +#'period because it is initialized too early (e.g.: Initialization on November +#'1st the forecast covers until the beginning of June next year), a climatology +#'(or other references) could be added at the end of the forecast lead time to +#'cover the desired period (e.g.: until the end of summer). +#' +#'This function is created to merge observations and forecasts, known as the +#'‘blending’ strategy (see references). The basis for this strategy is that the +#'predictions are progressively replaced with observational data as soon as they +#'become available (i.e., when entering the indicator definition period). This +#'key strategy aims to increase users’ confidence in the reformed predictions. #' -#'@param data1 An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. -#'@param data2 An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data1 An 's2dv_cube' object with the element 'data' being a +#' multidimensional array with named dimensions. All dimensions must be +#' equal to 'data2' dimensions except for the ones specified with 'memb_dim' +#' and 'time_dim'. If 'start1' and 'end1' are used to subset a period, the +#' Dates must be stored in element '$attrs$Dates' of the object. Dates must +#' have same time dimensions as element 'data'. +#'@param data2 An 's2dv_cube' object with the element 'data' being a +#' multidimensional array of named dimensions matching the dimensions of +#' parameter 'data1'. All dimensions must be equal to 'data1' except for the +#' ones specified with 'memb_dim' and 'time_dim'. If 'start2' and 'end2' are +#' used to subset a period, the Dates must be stored in element '$attrs$Dates' +#' of the object. Dates must have same time dimensions as element 'data'. #'@param start1 A list to define the initial date of the period to select from -#' data1 by providing a list of two elements: the initial date of the period +#' 'data1' by providing a list of two elements: the initial date of the period #' and the initial month of the period. #'@param end1 A list to define the final date of the period to select from -#' data1 by providing a list of two elements: the final day of the period and +#' 'data1' by providing a list of two elements: the final day of the period and #' the final month of the period. #'@param start2 A list to define the initial date of the period to select from -#' data2 by providing a list of two elements: the initial date of the period +#' 'data2' by providing a list of two elements: the initial date of the period #' and the initial month of the period. #'@param end2 A list to define the final date of the period to select from -#' data2 by providing a list of two elements: the final day of the period and +#' 'data2' by providing a list of two elements: the final day of the period and #' the final month of the period. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name -#' matching the dimensions provided in the object \code{data$data} can be -#' specified. This dimension is required to subset the data in a requested period. -#'@param sdate_dim A character string indicating the name of the dimension in -#' which the initialization dates are stored. +#' dimension that will be used to combine the two arrays. By default, it is set +#' to 'time'. Also, it will be used to subset the data in a requested +#' period. +#'@param memb_dim A character string indicating the name of the member +#' dimension. If the data are not ensemble ones, set as NULL. The default +#' value is 'member'. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. -#'@return A 's2dv_cube' object containing the indicator in the element -#' \code{data}. +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data}. The element \code{data} will be a multidimensional array created +#'from the combination of 'data1' and 'data2'. The resulting array will contain +#'the following dimensions: the original dimensions of the input data, which are +#'common to both arrays and for the 'time_dim' dimension, the sum of the +#'corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, +#'regarding member dimension, two different situations can occur: (1) in the +#'case that one of the arrays does not have member dimension or is equal to 1 +#'and the other array has multiple member dimension, the result will contain the +#'repeated values of the array one up to the lenght of member dimension of array +#'two; (2) in the case that both arrays have member dimension and is greater +#'than 1, all combinations of member dimension will be returned. The other +#'elements of the 's2dv_cube' will be updated with the combined information of +#'both datasets. +#' +#'@references Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +#'M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +#'N. González-Reviriego (2023). Advanced seasonal predictions for vine +#'management based on bioclimatic indicators tailored to the wine sector. +#'Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. #' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), #' seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) -#'dim(data_dates) <- c(ftime = 154, sdate = 2) +#'dim(data_dates) <- c(time = 154, sdate = 2) #'data <- NULL -#'data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member= 2)) +#'data$data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) #'data$attrs$Dates<- data_dates #'class(data) <- 's2dv_cube' #'ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day") -#'dim(ref_dates) <- c(ftime = 350, sdate = 2) +#'dim(ref_dates) <- c(time = 350, sdate = 2) #'ref <- NULL -#'ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) +#'ref$data <- array(1001:1700, c(time = 350, sdate = 2)) #'ref$attrs$Dates <- ref_dates #'class(ref) <- 's2dv_cube' #'new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, #' start1 = list(21, 6), end1 = list(30, 6), #' start2 = list(1, 7), end2 = list(21, 9)) -#' -#'@import multiApply +#' #'@export -CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, - time_dim = 'ftime', sdate_dim = 'sdate', +CST_MergeRefToExp <- function(data1, data2, start1 = NULL, end1 = NULL, + start2 = NULL, end2 = NULL, + time_dim = 'time', memb_dim = 'member', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data1, 's2dv_cube')) { - stop("Parameter 'ref' must be of the class 's2dv_cube'.") + stop("Parameter 'data1' must be of the class 's2dv_cube'.") } if (!inherits(data2, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube'.") + stop("Parameter 'data2' must be of the class 's2dv_cube'.") } # Dates subset of data1 - dates1 <- NULL if (!is.null(start1) && !is.null(end1)) { if (is.null(dim(data1$attrs$Dates))) { warning("Dimensions in 'data1' element 'attrs$Dates' are missed and ", "all data would be used.") - start <- NULL - end <- NULL - } else { - dates1 <- data1$attrs$Dates + start1 <- NULL + end1 <- NULL } } # Dates subset of data2 - dates2 <- NULL if (!is.null(start2) && !is.null(end2)) { if (is.null(dim(data2$attrs$Dates))) { warning("Dimensions in 'data2' element 'attrs$Dates' are missed and ", "all data would be used.") - start <- NULL - end <- NULL - } else { - dates2 <- data2$attrs$Dates + start2 <- NULL + end2 <- NULL } } + dates1 <- data1$attrs$Dates + dates2 <- data2$attrs$Dates + + # data data1$data <- MergeRefToExp(data1 = data1$data, dates1 = dates1, start1 = start1, end1 = end1, data2 = data2$data, dates2 = dates2, - start2, end2, time_dim = time_dim, - sdate_dim = sdate_dim, ncores = ncores) + start2, end2, time_dim = time_dim, + memb_dim = memb_dim, ncores = ncores) + # dims + data1$dims <- dim(data1$data) + + # coords + for (i_dim in names(dim(data1$data))) { + if (length(data1$coords[[i_dim]]) != dim(data1$data)[i_dim]) { + data1$coords[[i_dim]] <- NULL + data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] + attr(data1$coords[[i_dim]], 'indices') <- TRUE + } else if (length(data1$coords[[i_dim]]) == length(data2$coords[[i_dim]])) { + if (any(as.vector(data1$coords[[i_dim]]) != as.vector(data2$coords[[i_dim]]))) { + data1$coords[[i_dim]] <- NULL + data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] + attr(data1$coords[[i_dim]], 'indices') <- TRUE + } else if (!identical(attributes(data1$coords[[i_dim]]), + attributes(data2$coords[[i_dim]]))) { + attributes(data1$coords[[i_dim]]) <- NULL + } + } else { + data1$coords[[i_dim]] <- NULL + data1$coords[[i_dim]] <- 1:dim(data1$data)[i_dim] + attr(data1$coords[[i_dim]], 'indices') <- TRUE + } + } + + # Dates if (!is.null(dates1)) { - data1$attrs$Dates <- SelectPeriodOnDates(dates1, start = start1, end = end1, - time_dim = time_dim) + if (!is.null(start1) && !is.null(end1)) { + dates1 <- SelectPeriodOnDates(dates1, start = start1, end = end1, + time_dim = time_dim) + } } if (!is.null(dates2)) { - data2$attrs$Dates <- SelectPeriodOnDates(dates2, start = start2, - end = end2, time_dim = time_dim) + if ((!is.null(start2) && !is.null(end2))) { + dates2 <- SelectPeriodOnDates(dates2, start = start2, + end = end2, time_dim = time_dim) + } } - # TO DO CONCATENATE DATES - remove_dates1_dim <- FALSE - remove_dates2_dim <- FALSE - if (!is.null(data1$attrs$Dates) & !is.null(data2$attrs$Dates)) { - if (is.null(dim(data1$attrs$Dates))) { - remove_dates1_dim <- TRUE - dim(data1$attrs$Dates) <- length(data1$attrs$Dates) - names(dim(data1$attrs$Dates)) <- time_dim + remove_dates_dim <- FALSE + + if (!is.null(dates1) & !is.null(dates2)) { + if (is.null(dim(dates1))) { + remove_dates_dim <- TRUE + dim(dates1) <- length(dates1) + names(dim(dates1)) <- time_dim } - if (is.null(dim(data2$attrs$Dates))) { - remove_dates2_dim <- TRUE - dim(data2$attrs$Dates) <- length(data2$attrs$Dates) - names(dim(data2$attrs$Dates)) <- time_dim + if (is.null(dim(dates2))) { + remove_dates_dim <- TRUE + dim(dates2) <- length(dates2) + names(dim(dates2)) <- time_dim } } - res <- Apply(list(data1$attrs$Dates, data2$attrs$Dates), target_dims = time_dim, - c, output_dims = time_dim, ncores = ncores)$output1 - if (inherits(data1$attrs$Dates, 'Date')) { + res <- Apply(list(dates1, dates2), target_dims = time_dim, + 'c', output_dims = time_dim, ncores = ncores)$output1 + + if (inherits(dates1, 'Date')) { data1$attrs$Dates <- as.Date(res, origin = '1970-01-01') } else { - data1$attrs$Dates <- as.POSIXct(res*3600*24, origin = '1970-01-01', tz = 'UTC') + data1$attrs$Dates <- as.POSIXct(res, origin = '1970-01-01', tz = 'UTC') } - if (remove_dates1_dim) { + if (remove_dates_dim) { dim(data1$attrs$Dates) <- NULL } - if (remove_dates2_dim) { - dim(data2$attrs$Dates) <- NULL - } + # Variable + data1$attrs$Variable$varName <- unique(data1$attrs$Variable$varName, + data2$attrs$Variable$varName) + names_metadata <- names(data1$attrs$Variable$metadata) + data1$attrs$Variable$metadata <- intersect(data1$attrs$Variable$metadata, + data2$attrs$Variable$metadata) + names(data1$attrs$Variable$metadata) <- names_metadata + + # source_files + data1$attrs$source_files <- unique(c(data1$attrs$source_files, data2$attrs$source_files)) + + # Datasets + data1$attrs$Datasets <- unique(c(data1$attrs$Datasets, data2$attrs$Datasets)) + + # when + data1$attrs$when <- Sys.time() + + # load_parameters (TO DO: remove with CST_Start) + if (!is.null(c(data1$attrs$load_parameters, data2$attrs$load_parameters))) { + data1$attrs$load_parameters <- list(data1 = data1$attrs$load_parameters, + data2 = data2$attrs$load_parameters) + } + return(data1) } @@ -148,40 +228,75 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #'Some indicators are defined for specific temporal periods (e.g.: summer from #'June 21st to September 21st). If the initialization forecast date is later #'than the one required for the indicator (e.g.: July 1st), the user may want to -#'merge past observations, or other reference, to the forecast (or hindcast) to -#'compute the indicator. The function \code{MergeObs2Exp} takes care of this -#'steps. +#'merge past observations, or other references, to the forecast (or hindcast) to +#'compute the indicator. If the forecast simulation doesn't cover the required +#'period because it is initialized too early (e.g.: Initialization on November +#'1st the forecast covers until the beginning of June next year), a climatology +#'(or other references) could be added at the end of the forecast lead time to +#'cover the desired period (e.g.: until the end of summer). +#' +#'This function is created to merge observations and forecasts, known as the +#'‘blending’ strategy (see references). The basis for this strategy is that the +#'predictions are progressively replaced with observational data as soon as they +#'become available (i.e., when entering the indicator definition period). This +#'key strategy aims to increase users’ confidence in the reformed predictions. #' -#'@param data1 A multidimensional array with named dimensions. -#'@param dates1 A vector of dates or a multidimensional array of dates with -#' named dimensions matching the dimensions on parameter 'data1'. -#'@param data2 A multidimensional array with named dimensions. -#'@param dates2 A vector of dates or a multidimensional array of dates with -#' named dimensions matching the dimensions on parameter 'data2'. +#'@param data1 A multidimensional array with named dimensions. All dimensions +#' must be equal to 'data2' dimensions except for the ones specified with +#' 'memb_dim' and 'time_dim'. +#'@param dates1 A multidimensional array of dates with named dimensions matching +#' the temporal dimensions of parameter 'data1'. The common dimensions must be +#' equal to 'data1' dimensions. +#'@param data2 A multidimensional array of named dimensions matching the +#' dimensions of parameter 'data1'. All dimensions must be equal to 'data1' +#' except for the ones specified with 'memb_dim' and 'time_dim'. +#'@param dates2 A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data2'. The common dimensions must be +#' equal to 'data2' dimensions. #'@param start1 A list to define the initial date of the period to select from -#' data1 by providing a list of two elements: the initial date of the period -#' and the initial month of the period. +#' 'data1' by providing a list of two elements: the initial date of the period +#' and the initial month of the period. The initial date of the period must be +#' included in the 'dates1' array. #'@param end1 A list to define the final date of the period to select from -#' data1 by providing a list of two elements: the final day of the period and -#' the final month of the period. +#' 'data1' by providing a list of two elements: the final day of the period and +#' the final month of the period. The final date of the period must be +#' included in the 'dates1' array. #'@param start2 A list to define the initial date of the period to select from -#' data2 by providing a list of two elements: the initial date of the period -#' and the initial month of the period. +#' 'data2' by providing a list of two elements: the initial date of the period +#' and the initial month of the period. The initial date of the period must be +#' included in the 'dates2' array. #'@param end2 A list to define the final date of the period to select from -#' data2 by providing a list of two elements: the final day of the period and -#' the final month of the period. +#' 'data2' by providing a list of two elements: the final day of the period and +#' the final month of the period. The final date of the period must be +#' included in the 'dates2' array. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name -#' matching the dimensions provided in the object \code{data$data} can be -#' specified. This dimension is required to subset the data in a requested +#' dimension that will be used to combine the two arrays. By default, it is set +#' to 'time'. Also, it will be used to subset the data in a requested #' period. -#'@param sdate_dim A character string indicating the name of the dimension in -#' which the initialization dates are stored. +#'@param memb_dim A character string indicating the name of the member +#' dimension. If the 'data1' and 'data2' have no member dimension, set it as +#' NULL. It is set as 'member' by default. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' -#'@return A multidimensional array with named dimensions. -#' +#'@return A multidimensional array created from the combination of 'data1' and +#''data2'. The resulting array will contain the following dimensions: the +#'original dimensions of the input data, which are common to both arrays and for +#'the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' +#'and 'data2'. If 'memb_dim' is not null, regarding member dimension, two +#'different situations can occur: (1) in the case that one of the arrays does +#'not have member dimension or is equal to 1 and the other array has multiple +#'member dimension, the result will contain the repeated values of the array one +#'up to the lenght of member dimension of array two; (2) in the case that both +#'arrays have member dimension and is greater than 1, all combinations of member +#'dimension will be returned. +#' +#'@references Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +#'M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +#'N. González-Reviriego (2023). Advanced seasonal predictions for vine +#'management based on bioclimatic indicators tailored to the wine sector. +#'Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. +#' #'@examples #'data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), #' as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), @@ -192,7 +307,7 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #' as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day") #'dim(ref_dates) <- c(time = 350, sdate = 2) #'ref <- array(1001:1700, c(time = 350, sdate = 2)) -#'data <- array(1:(2*154*2), c(time = 154, sdate = 2, member= 2)) +#'data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) #'new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), #' end1 = list(30, 6), data2 = data, dates2 = data_dates, #' start2 = list(1, 7), end = list(21, 9), @@ -200,76 +315,121 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #' #'@import multiApply #'@export -MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, - end2, time_dim = 'ftime', sdate_dim = 'sdate', +MergeRefToExp <- function(data1, data2, dates1 = NULL, dates2 = NULL, + start1 = NULL, end1 = NULL, start2 = NULL, end2 = NULL, + time_dim = 'time', memb_dim = 'member', ncores = NULL) { # Input checks - # data - if (!is.array(data1)) { - dim(data1) <- c(length(data1)) - names(dim(data1)) <- time_dim + ## data1 and data2 + if (!is.array(data1) | !is.array(data2)) { + stop("Parameters 'data1' and 'data2' must be arrays.") } - if (!is.array(data2)) { - dim(data2) <- c(length(data2)) - names(dim(data2)) <- time_dim + if (is.null(names(dim(data1))) | is.null(names(dim(data2)))) { + stop("Parameters 'data1' and 'data2' must have named dimensions.") } - # dates - if (!is.null(dates1) & !is.null(dates2)) { - if (is.null(dim(dates1))) { - warning("Dimensions in 'dates1' element are missed and ", - "all data would be used.") - dim(dates1) <- length(dates1) - names(dim(dates1)) <- time_dim + ## time_dim + if (!is.character(time_dim)) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data1)) | !time_dim %in% names(dim(data2))) { + stop("Parameter 'time_dim' is not found in 'data1' or 'data2' dimension ", + "names.") + } + ## memb_dim + data1dims <- names(dim(data1)) + data2dims <- names(dim(data2)) + if (!is.null(memb_dim)) { + if (!is.character(memb_dim)) { + stop("Parameter 'memb_dim' must be a character string.") } - if (is.null(dim(dates2))) { - warning("Dimensions in 'dates2' element are missed and ", - "all data would be used.") - dim(dates2) <- length(dates2) - names(dim(dates2)) <- time_dim + if (!memb_dim %in% names(dim(data1)) & !memb_dim %in% names(dim(data2))) { + stop("Parameter 'memb_dim' is not found in 'data1' or 'data2' dimension. ", + "Set it to NULL if there is no member dimension.") + } + if ((memb_dim %in% names(dim(data1)) & memb_dim %in% names(dim(data2)))) { + if (dim(data1)[memb_dim] != dim(data2)[memb_dim]) { + if (dim(data1)[memb_dim] == 1) { + data1 <- array(data1, dim = dim(data1)[-which(names(dim(data1)) == memb_dim)]) + } else if (dim(data2)[memb_dim] == 1) { + data2 <- array(data2, dim = dim(data2)[-which(names(dim(data2)) == memb_dim)]) + } else { + memb_dim1 <- dim(data1)[memb_dim] + data1 <- Apply(list(data1), target_dims = memb_dim, + fun = function(x, memb_rep) { + return(rep(x, each = memb_rep)) + }, memb_rep = dim(data2)[memb_dim], + output_dims = memb_dim, ncores = ncores)$output1 + data2 <- Apply(list(data2), target_dims = memb_dim, + fun = function(x, memb_rep) { + return(rep(x, memb_rep)) + }, memb_rep = memb_dim1, + output_dims = memb_dim, ncores = ncores)$output1 + } + } } - data1 <- SelectPeriodOnData(data1, dates = dates1, start = start1, - end = end1, time_dim = time_dim, ncores = ncores) } + ## data1 and data2 (2) + name_data1 <- sort(names(dim(data1))) + name_data2 <- sort(names(dim(data2))) - # Check if data2 has dimension sdate_dim and it should be added to data1: - if ((sdate_dim %in% names(dim(data2))) && dim(data2)[sdate_dim] > 1 && - !sdate_dim %in% names(dim(data1))) { - dim(data1) <- c(length(data1)/dim(data2)[sdate_dim], dim(data2)[sdate_dim]) - names(dim(data1)) <- c(time_dim, sdate_dim) - } - # Check if data1 has dimension sdate_dim and it should be added to data2: - if ((sdate_dim %in% names(dim(data1))) && dim(data1)[sdate_dim] > 1 && - !sdate_dim %in% names(dim(data2))) { - dim(data2) <- c(length(data2)/dim(data1)[sdate_dim], dim(data1)[sdate_dim]) - names(dim(data2)) <- c(time_dim, sdate_dim) + name_data1 <- name_data1[-which(name_data1 %in% c(time_dim, memb_dim))] + name_data2 <- name_data2[-which(name_data2 %in% c(time_dim, memb_dim))] + + if (!identical(length(name_data1), length(name_data2)) | + !identical(dim(data1)[name_data1], dim(data2)[name_data2])) { + stop(paste0("Parameter 'data1' and 'data2' must have same length of ", + "all dimensions except 'memb_dim'.")) } - # Check if data1 needs to be extended to the length of the dimensions of data2: - if (length(dim(data2)) != length(dim(data1))) { - dif_dims <- which(names(dim(data2)) %in% names(dim(data1)) == FALSE) - if (length(dif_dims) > 0) { - for (i in dif_dims) { - data1 <- .insertdim(data1, posdim = i, lendim = dim(data2)[i], - name = names(dim(data2))[i]) + ## dates1 + if (!is.null(start1) & !is.null(end1)) { + if (is.null(dates1)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else if (!all(c(is.list(start1), is.list(end1)))) { + warning("Parameter 'start1' and 'end1' must be lists indicating the ", + "day and the month of the period start and end. Full data ", + "will be used.") + } else { + if (!is.null(dim(dates1))) { + data1 <- SelectPeriodOnData(data = data1, dates = dates1, start = start1, + end = end1, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates1' must have named dimensions if 'start' and ", + "'end' are not NULL. All 'data1' will be used.") } } } - # Check if data2 needs to be extended to the length of the dimensions of data1: - if (length(dim(data1)) != length(dim(data2))) { - dif_dims <- which(names(dim(data1)) %in% names(dim(data2)) == FALSE) - if (length(dif_dims) > 0) { - for (i in dif_dims) { - data2 <- .insertdim(data2, posdim = i, lendim = dim(data1)[i], - name = names(dim(data1))[i]) + ## dates2 + if (!is.null(start2) & !is.null(end2)) { + if (is.null(dates2)) { + warning("Parameter 'dates2' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else if (!all(c(is.list(start2), is.list(end2)))) { + warning("Parameter 'start2' and 'end2' must be lists indicating the ", + "day and the month of the period start and end. Full data ", + "will be used.") + } else { + if (!is.null(dim(dates2))) { + data2 <- SelectPeriodOnData(data = data2, dates = dates2, start = start2, + end = end2, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates2' must have named dimensions if 'start2' and ", + "'end2' are not NULL. All 'data2' will be used.") } } } - if (!is.null(dates2)) { - data2 <- SelectPeriodOnData(data2, dates = dates2, start = start2, - end = end2, time_dim = time_dim, ncores = ncores) - } + data1 <- Apply(list(data1, data2), target_dims = time_dim, fun = 'c', output_dims = time_dim, ncores = ncores)$output1 + + if (all(names(dim(data1)) %in% data1dims)) { + pos <- match(data1dims, names(dim(data1))) + data1 <- aperm(data1, pos) + } else if (all(names(dim(data1)) %in% data2dims)) { + pos <- match(data2dims, names(dim(data1))) + data1 <- aperm(data1, pos) + } return(data1) } - - diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index d181d8eeaa71100948ffa1594fce8d6ebadd376f..8986e3ff97e070c87550fb8c4c840617f1d2b55f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -4,65 +4,108 @@ #'period. Providing precipitation data, two agriculture indices can be obtained #'by using this function: #'\itemize{ -#' \item\code{SprR}{Spring Total Precipitation: The total precipitation from -#' April 21th to June 21st} -#' \item\code{HarR}{Harvest Total Precipitation: The total precipitation from -#' August 21st to October 21st} +#' \item{'SprR', Spring Total Precipitation: The total precipitation from +#' April 21th to June 21st.} +#' \item{'HarR', Harvest Total Precipitation: The total precipitation from +#' August 21st to October 21st.} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'There are two possible ways of performing the accumulation. The default one +#'is by accumulating a variable over a dimension specified with 'time_dim'. To +#'chose a specific time period, 'start' and 'end' must be used. The other method +#'is by using 'rollwidth' parameter. When this parameter is a positive integer, +#'the cumulative backward sum is applied to the time dimension. If it is +#'negative, the rolling sum is applied backwards. This function is build to +#'be compatible with other tools in that work with 's2dv_cube' object class. The +#'input data must be this object class. If you don't work with 's2dv_cube', see +#'PeriodAccumulation. +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial -#' date of the period and the initial month of the period. By default it is set -#' to NULL and the indicator is computed using all the data provided in +#' date of the period and the initial m onth of the period. By default it is +#' set to NULL and the indicator is computed using all the data provided in #' \code{data}. #'@param end An optional parameter to defined the final date of the period to #' select from the data by providing a list of two elements: the final day of #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. +#'@param rollwidth An optional parameter to indicate the number of time +#' steps the rolling sum is applied to. If it is positive, the rolling sum is +#' applied backwards 'time_dim', if it is negative, it will be forward it. When +#' this parameter is NULL, the sum is applied over all 'time_dim', in a +#' specified period. It is NULL by default. +#'@param sdate_dim (Only needed when rollwidth is used). A character string +#' indicating the name of the start date dimension to compute the rolling +#' accumulation. By default, it is set to 'sdate'. +#'@param frequency (Only needed when rollwidth is used). A character string +#' indicating the time frequency of the data to apply the rolling accumulation. +#' It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +#' continuous months will be accumulated; if it is 'daliy', values from +#' continuous days will be accumulated. It is set to 'monthly' by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' -#'@return A 's2dv_cube' object containing the indicator in the element -#'\code{data}. +#'@return An 's2dv_cube' object containing the accumulated data in the element +#'\code{data}. If parameter 'rollwidth' is not used, it will have the dimensions +#'of the input parameter 'data' except the dimension where the accumulation has +#'been computed (specified with 'time_dim'). If 'rollwidth' is used, it will be +#'of same dimensions as input data. The 'Dates' array is updated to the +#'dates corresponding to the beginning of the aggregated time period. A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. If 'rollwidth' is used, it will contain the same dimensions of +#'parameter 'data' and the other elements of the 's2dv_cube' will not be +#'modified. #' #'@examples #'exp <- NULL #'exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, #' ftime = 9, lat = 2, lon = 2)) #'class(exp) <- 's2dv_cube' -#'TP <- CST_PeriodAccumulation(exp) -#'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), -#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), -#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), -#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), -#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) +#'TP <- CST_PeriodAccumulation(exp, time_dim = 'ftime') +#'exp$data <- array(rnorm(5 * 3 * 214 * 2), +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'exp$attrs$Dates <- Dates +#'SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), +#' time_dim = 'ftime') #'dim(SprR$data) #'head(SprR$attrs$Dates) -#'HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10)) +#'HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10), +#' time_dim = 'ftime') #'dim(HarR$data) #'head(HarR$attrs$Dates) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, - ncores = NULL) { + time_dim = 'time', rollwidth = NULL, + sdate_dim = 'sdate', frequency = 'monthly', + na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + if (!all(c('data') %in% names(data))) { + stop("Parameter 'data' doesn't have 's2dv_cube' structure. ", + "Use PeriodAccumulation instead.") + } # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -73,15 +116,32 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, } } - total <- PeriodAccumulation(data$data, dates = data$attrs$Dates, start, end, - time_dim = time_dim, na.rm = na.rm, ncores = ncores) - data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + Dates <- data$attrs$Dates + data$data <- PeriodAccumulation(data = data$data, dates = Dates, + start = start, end = end, + time_dim = time_dim, rollwidth = rollwidth, + sdate_dim = sdate_dim, frequency = frequency, + na.rm = na.rm, ncores = ncores) + data$dims <- dim(data$data) + if (!is.null(start) & !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- Dates + } + if (is.null(rollwidth)) { + data$coords[[time_dim]] <- NULL + if (!is.null(dim(Dates))) { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- Subset(Dates, time_dim, 1, drop = 'selected') + time_bounds$end <- Subset(Dates, time_dim, dim(Dates)[time_dim], drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } + return(data) } @@ -91,16 +151,23 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'period. Providing precipitation data, two agriculture indices can be obtained #'by using this function: #'\itemize{ -#' \item\code{SprR}{Spring Total Precipitation: The total precipitation from -#' April 21th to June 21st} -#' \item\code{HarR}{Harvest Total Precipitation: The total precipitation from -#' August 21st to October 21st} +#' \item{'SprR', Spring Total Precipitation: The total precipitation from +#' April 21th to June 21st.} +#' \item{'HarR', Harvest Total Precipitation: The total precipitation from +#' August 21st to October 21st.} #'} +#' +#'There are two possible ways of performing the accumulation. The default one +#'is by accumulating a variable over a dimension specified with 'time_dim'. To +#'chose a specific time period, 'start' and 'end' must be used. The other method +#'is by using 'rollwidth' parameter. When this parameter is a positive integer, +#'the cumulative backward sum is applied to the time dimension. If it is +#'negative, the rolling sum is applied backwards. #' #'@param data A multidimensional array with named dimensions. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -111,60 +178,173 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'time'. More than one -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. +#' compute the indicator. By default, it is set to 'time'. +#'@param rollwidth An optional parameter to indicate the number of time +#' steps the rolling sum is applied to. If it is positive, the rolling sum is +#' applied backwards 'time_dim', if it is negative, it will be forward it. When +#' this parameter is NULL, the sum is applied over all 'time_dim', in a +#' specified period. It is NULL by default. +#'@param sdate_dim (Only needed when rollwidth is used). A character string +#' indicating the name of the start date dimension to compute the rolling +#' accumulation. By default, it is set to 'sdate'. +#'@param frequency (Only needed when rollwidth is used). A character string +#' indicating the time frequency of the data to apply the rolling accumulation. +#' It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +#' continuous months will be accumulated; if it is 'daliy', values from +#' continuous days will be accumulated. It is set to 'monthly' by default. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). #'@param ncores An integer indicating the number of cores to use in parallel #' computation. -#' #'@return A multidimensional array with named dimensions containing the -#'indicator in the element \code{data}. +#'accumulated data in the element \code{data}. If parameter 'rollwidth' is +#'not used, it will have the dimensions of the input 'data' except the dimension +#'where the accumulation has been computed (specified with 'time_dim'). If +#''rollwidth' is used, it will be of same dimensions as input data. #' #'@examples #'exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, #' ftime = 9, lat = 2, lon = 2)) #'TP <- PeriodAccumulation(exp, time_dim = 'ftime') #'data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, time = 214, lon = 2)) -#'# ftime tested +#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), end = list(21, 6)) -#'HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), end = list(21, 10)) +#'dim(Dates) <- c(sdate = 3, ftime = 214) +#'SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), +#' end = list(21, 6), time_dim = 'ftime') +#'HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), +#' end = list(21, 10), time_dim = 'ftime') #' #'@import multiApply +#'@importFrom zoo rollapply #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, - ncores = NULL) { + time_dim = 'time', rollwidth = NULL, + sdate_dim = 'sdate', frequency = 'monthly', + na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) names(dim(data)) <- time_dim } - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + dimnames <- names(dim(data)) + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", - "day and the month of the period start and end.") + "day and the month of the period start and end.") } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data, dates, start, end, + time_dim = time_dim, ncores = ncores) + if (!is.null(rollwidth)) { + dates <- SelectPeriodOnDates(dates = dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + + if (is.null(rollwidth)) { + # period accumulation + total <- Apply(list(data), target_dims = time_dim, fun = sum, + na.rm = na.rm, ncores = ncores)$output1 + } else { + # rolling accumulation + ## dates + if (is.null(dates)) { + stop("Parameter 'dates' is NULL. Cannot compute the rolling accumulation.") + } + + ## rollwidth + if (!is.numeric(rollwidth)) { + stop("Parameter 'rollwidth' must be a numeric value.") + } + if (abs(rollwidth) > dim(data)[time_dim]) { + stop(paste0("Cannot compute accumulation of ", rollwidth, " months because ", + "loaded data has only ", dim(data)[time_dim], " months.")) + } + ## sdate_dim + if (!is.character(sdate_dim) | length(sdate_dim) != 1) { + stop("Parameter 'sdate_dim' must be a character string.") } + if (!sdate_dim %in% names(dim(data))) { + stop("Parameter 'sdate_dim' is not found in 'data' dimension.") + } + ## frequency + if (!is.character(frequency)) { + stop("Parameter 'frequency' must be a character string.") + } + + forwardroll <- FALSE + if (rollwidth < 0) { + rollwidth <- abs(rollwidth) + forwardroll <- TRUE + } + + mask_dates <- .datesmask(dates, frequency = frequency) + total <- Apply(data = list(data), + target_dims = list(data = c(time_dim, sdate_dim)), + fun = .rollaccumulation, + mask_dates = mask_dates, + rollwidth = rollwidth, + forwardroll = forwardroll, na.rm = na.rm, + output_dims = c(time_dim, sdate_dim), + ncores = ncores)$output1 + + pos <- match(dimnames, names(dim(total))) + total <- aperm(total, pos) } - total <- Apply(list(data), target_dims = time_dim, fun = sum, - na.rm = na.rm, ncores = ncores)$output1 + return(total) } +.rollaccumulation <- function(data, mask_dates, rollwidth = 1, + forwardroll = FALSE, na.rm = FALSE) { + dims <- dim(data) + data_vector <- array(NA, dim = length(mask_dates)) + count <- 1 + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { + data_vector[dd] <- as.vector(data)[count] + count <- count + 1 + } + } + + data_accum <- rollapply(data = data_vector, width = rollwidth, FUN = sum, na.rm = na.rm) + if (!forwardroll) { + data_accum <- c(rep(NA, rollwidth-1), data_accum) + } else { + data_accum <- c(data_accum, rep(NA, rollwidth-1)) + } + + data_accum <- data_accum[which(mask_dates == 1)] + data_accum <- array(data_accum, dim = c(dims)) + return(data_accum) +} diff --git a/R/PeriodMax.R b/R/PeriodMax.R new file mode 100644 index 0000000000000000000000000000000000000000..3ae23ec4d519572de99059183cc980fb5e40df57 --- /dev/null +++ b/R/PeriodMax.R @@ -0,0 +1,213 @@ +#'Period Max on 's2dv_cube' objects +#' +#'Period Max computes the maximum (max) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item{'BIO5', (Providing temperature data) Max Temperature of Warmest +#' Month. The maximum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO13', (Providing precipitation data) Precipitation of Wettest +#' Month. This index identifies the total precipitation +#' that prevails during the wettest month.} +#'} +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'time'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the max has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'res <- CST_PeriodMax(exp, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodMax <- function(data, start = NULL, end = NULL, + time_dim = 'time', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodMax(data = data$data, dates = Dates, start = start, end = end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + data$data <- total + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period max on multidimensional array objects +#' +#'Period max computes the average (max) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item{'BIO5', (Providing temperature data) Max Temperature of Warmest +#' Month. The maximum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO13', (Providing precipitation data) Precipitation of Wettest +#' Month. This index identifies the total precipitation +#' that prevails during the wettest month.} +#'} +#' +#'@param data A multidimensional array with named dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'time'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'res <- PeriodMax(data, dates = Dates, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodMax <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, fun = max, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + + diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 85a12a74272726c3694425fe1728181409d956b1..f58bbeb27c9fc1e12efd8de06b058efd3be737be 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -4,14 +4,14 @@ #'Providing temperature data, two agriculture indices can be obtained by using #'this function: #'\itemize{ -#' \item\code{GST}{Growing Season average Temperature: The average temperature -#' from April 1st to Octobe 31st} -#' \item\code{SprTX}{Spring Average Maximum Temperature: The average daily -#' maximum temperature from April 1st to May 31st} +#' \item{'GST', Growing Season average Temperature: The average temperature +#' from April 1st to Octobe 31st.} +#' \item{'SprTX', Spring Average Maximum Temperature: The average daily +#' maximum temperature from April 1st to May 31st.} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -22,7 +22,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -31,27 +31,42 @@ #' computation. #' #'@return An 's2dv_cube' object containing the indicator in the element -#' \code{data}. +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the mean has been computed (specified with 'time_dim'). The +#''Dates' array is updated to the dates corresponding to the beginning of the +#'aggregated time period. A new element called 'time_bounds' will be added into +#'the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL -#'exp$data <- array(rnorm(45), dim = c(member = 7, ftime = 8)) +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'exp$attrs$Dates <- Dates #'class(exp) <- 's2dv_cube' -#'exp$attrs$Dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), -#' as.Date("01-08-1993","%d-%m-%Y", tz = 'UTC'), "day"), -#' seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), -#' as.Date("01-08-1994","%d-%m-%Y", tz = 'UTC'), "day")) -#'SA <- CST_PeriodMean(exp) +#' +#'SA <- CST_PeriodMean(exp, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_PeriodMean <- function(data, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { - # Check 's2dv_cube' + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { stop("Parameter 'data' must be of the class 's2dv_cube'.") } + # Dates subset if (!is.null(start) && !is.null(end)) { if (is.null(dim(data$attrs$Dates))) { @@ -62,14 +77,36 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, } } - total <- PeriodMean(data = data$data, dates = data$attrs$Dates, start, end, + Dates <- data$attrs$Dates + total <- PeriodMean(data = data$data, dates = Dates, start = start, end = end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) + data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } return(data) } @@ -80,16 +117,16 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'Providing temperature data, two agriculture indices can be obtained by using #'this function: #'\itemize{ -#' \item\code{GST}{Growing Season average Temperature: The average -#' temperature from April 1st to Octobe 31st} -#' \item\code{SprTX}{Spring Average Maximum Temperature: The average daily -#' maximum temperature from April 1st to May 31st} +#' \item{'GST', Growing Season average Temperature: The average temperature +#' from April 1st to Octobe 31st.} +#' \item{'SprTX', Spring Average Maximum Temperature: The average daily +#' maximum temperature from April 1st to May 31st.} #'} #' #'@param data A multidimensional array with named dimensions. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -100,7 +137,7 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or @@ -112,39 +149,64 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, #'indicator in the element \code{data}. #' #'@examples -#'exp <- array(rnorm(56), dim = c(member = 7, ftime = 8)) -#'SA <- PeriodMean(exp, time_dim = 'ftime') +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'SA <- PeriodMean(data, dates = Dates, start = list(01, 12), end = list(01, 01)) #' #'@import multiApply #'@export PeriodMean <- function(data, dates = NULL, start = NULL, end = NULL, time_dim = 'time', na.rm = FALSE, ncores = NULL) { - + # Initial checks + ## data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } if (!is.array(data)) { dim(data) <- length(data) - names(data) <- time_dim + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") } - if (is.null(dates)) { - warning("Parameter 'dates' is NULL and the Average of the ", + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", "full data provided in 'data' is computed.") - } else { - if (!is.null(start) && !is.null(end)) { + } else { if (!any(c(is.list(start), is.list(end)))) { - stop("Parameter 'start' and 'end' must be lists indicating the ", - "day and the month of the period start and end.") + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) } } total <- Apply(list(data), target_dims = time_dim, fun = mean, na.rm = na.rm, ncores = ncores)$output1 + return(total) } diff --git a/R/PeriodMin.R b/R/PeriodMin.R new file mode 100644 index 0000000000000000000000000000000000000000..99ce8016a76fca9d80920abb2b44cf89094ad79d --- /dev/null +++ b/R/PeriodMin.R @@ -0,0 +1,213 @@ +#'Period Min on 's2dv_cube' objects +#' +#'Period Min computes the average (min) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item{'BIO6', (Providing temperature data) Min Temperature of Coldest +#' Month. The minimum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO14', (Providing precipitation data) Precipitation of Driest +#' Month. This index identifies the total precipitation +#' that prevails during the driest month.} +#'} +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'time'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the min has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'res <- CST_PeriodMin(exp, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodMin <- function(data, start = NULL, end = NULL, + time_dim = 'time', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodMin(data = data$data, dates = Dates, start = start, end = end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + data$data <- total + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period Min on multidimensional array objects +#' +#'Period Min computes the average (min) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item{'BIO6', (Providing temperature data) Min Temperature of Coldest +#' Month. The minimum monthly temperature occurrence over a +#' given year (time-series) or averaged span of years (normal).} +#' \item{'BIO14', (Providing precipitation data) Precipitation of Driest +#' Month. This index identifies the total precipitation +#' that prevails during the driest month.} +#'} +#' +#'@param data A multidimensional array with named dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'time'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'res <- PeriodMin(data, dates = Dates, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodMin <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, fun = min, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + + diff --git a/R/PeriodPET.R b/R/PeriodPET.R new file mode 100644 index 0000000000000000000000000000000000000000..27d6ecaeeed9d7a9e778426495348ebcd9f519ab --- /dev/null +++ b/R/PeriodPET.R @@ -0,0 +1,386 @@ +#'Compute the Potential Evapotranspiration +#' +#'Compute the Potential evapotranspiration (PET) that is the amount of +#'evaporation and transpiration that would occur if a sufficient water source +#'were available. This function calculate PET according to the Thornthwaite, +#'Hargreaves or Hargreaves-modified equations. +#' +#'This function is build to be compatible with other tools in +#'that work with 's2dv_cube' object class. The input data must be this object +#'class. If you don't work with 's2dv_cube', see PeriodPET. For more information +#'on the SPEI calculation, see functions CST_PeriodStandardization and +#'CST_PeriodAccumulation. +#' +#'@param data A named list with the needed \code{s2dv_cube} objects containing +#' the seasonal forecast experiment in the 'data' element for each variable. +#' Specific variables are needed for each method used in computing the +#' Potential Evapotranspiration (see parameter 'pet_method'). The accepted +#' variable names are fixed in order to be recognized by the function. +#' The accepted name corresponding to the Minimum Temperature is 'tmin', +#' for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +#' for Precipitation is 'pr'. The accepted variable names for each method are: +#' For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +#' 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +#' for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +#' degrees; the units for precipitation ('pr') need to be in mm/month. +#' Currently the function works only with monthly data from different years. +#'@param pet_method A character string indicating the method used to compute +#' the potential evapotranspiration. The accepted methods are: +#' 'hargreaves' and 'hargreaves_modified', that require the data to have +#' variables tmin and tmax; and 'thornthwaite', that requires variable +#' 'tmean'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param lat_dim A character string indicating the name of the latitudinal +#' dimension. By default it is set by 'latitude'. +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@examples +#'dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) +#'exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +#'end_year <- 2012 +#'dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), +#' paste0(2010:end_year, "-09-15"), +#' paste0(2010:end_year, "-10-16")), "UTC") +#'dim(dates_exp) <- c(syear = 3, time = 3) +#'lat <- c(40) +#'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +#'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) +#' +#'@importFrom CSTools s2dv_cube +#'@export +CST_PeriodPET <- function(data, pet_method = 'hargreaves', + time_dim = 'syear', leadtime_dim = 'time', + lat_dim = 'latitude', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!all(sapply(data, function(x) inherits(x, 's2dv_cube')))) { + stop("Parameter 'data' must be a list of 's2dv_cube' class.") + } + # latitude + if (!any(names(data[[1]]$coords) %in% .KnownLatNames())) { + stop("Spatial coordinate names of parameter 'data' do not match any ", + "of the names accepted by the package.") + } + # Dates + dates_exp <- data[[1]]$attrs$Dates + if (!'Dates' %in% names(data[[1]]$attrs)) { + stop("Element 'Dates' is not found in 'attrs' list of 'data'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") + } + lat_dim <- names(data[[1]]$coords)[[which(names(data[[1]]$coords) %in% .KnownLatNames())]] + + res <- PeriodPET(data = lapply(data, function(x) x$data), + dates = data[[1]]$attrs$Dates, + lat = data[[1]]$coords[[lat_dim]], + pet_method = pet_method, time_dim = time_dim, + leadtime_dim = leadtime_dim, lat_dim = lat_dim, + na.rm = na.rm, ncores = ncores) + # Add metadata + source_files <- lapply(data, function(x) {x$attrs$source_files}) + coords <- data[[1]]$coords + Dates <- data[[1]]$attrs$Dates + metadata <- data[[1]]$attrs$Variable$metadata + metadata_names <- intersect(names(dim(res)), names(metadata)) + suppressWarnings( + res <- s2dv_cube(data = res, coords = coords, + varName = paste0('PET'), + metadata = metadata[metadata_names], + Dates = Dates, + source_files = source_files, + when = Sys.time()) + ) + return(res) +} + +#'Compute the Potential Evapotranspiration +#' +#'Compute the Potential Evapotranspiration (PET) that is the amount of +#'evaporation and transpiration that would occur if a sufficient water source +#'were available. This function calculate PET according to the Thornthwaite, +#'Hargreaves or Hargreaves-modified equations. +#' +#'For more information on the SPEI calculation, see functions +#'PeriodStandardization and PeriodAccumulation. +#' +#'@param data A named list of multidimensional arrays containing +#' the seasonal forecast experiment data for each variable. +#' Specific variables are needed for each method used in computing the +#' Potential Evapotranspiration (see parameter 'pet_method'). The accepted +#' variable names are fixed in order to be recognized by the function. +#' The accepted name corresponding to the Minimum Temperature is 'tmin', +#' for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +#' for Precipitation is 'pr'. The accepted variable names for each method are: +#' For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +#' 'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +#' for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +#' degrees; the units for precipitation ('pr') need to be in mm/month. +#' Currently the function works only with monthly data from different years. +#'@param dates An array of temporal dimensions containing the Dates of +#' 'data'. It must be of class 'Date' or 'POSIXct'. +#'@param lat A numeric vector containing the latitude values of 'data'. +#'@param pet_method A character string indicating the method used to compute +#' the potential evapotranspiration. The accepted methods are: +#' 'hargreaves' and 'hargreaves_modified', that require the data to have +#' variables tmin and tmax; and 'thornthwaite', that requires variable +#' 'tmean'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param lat_dim A character string indicating the name of the latitudinal +#' dimension. By default it is set by 'latitude'. +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@examples +#'dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) +#'exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +#'exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +#'exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +#'end_year <- 2012 +#'dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), +#' paste0(2010:end_year, "-09-15"), +#' paste0(2010:end_year, "-10-16")), "UTC") +#'dim(dates_exp) <- c(syear = 3, time = 3) +#'lat <- c(40) +#'exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +#'res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) +#' +#'@importFrom SPEI hargreaves thornthwaite +#'@import multiApply +#'@export +PeriodPET <- function(data, dates, lat, pet_method = 'hargreaves', + time_dim = 'syear', leadtime_dim = 'time', + lat_dim = 'latitude', na.rm = FALSE, + ncores = NULL) { + + # Initial checks + # data + if (!inherits(data, 'list')) { + stop("Parameter 'data' needs to be a named list with the needed variables.") + } + if (is.null(names(data))) { + stop("Parameter 'data' needs to be a named list with the variable names.") + } + if (any(sapply(data, function(x) is.null(names(dim(x)))))) { + stop("Parameter 'data' needs to be a list of arrays with dimension names.") + } + dims <- lapply(data, function(x) dim(x)) + first_dims <- dims[[1]] + all_equal <- all(sapply(dims[-1], function(x) identical(first_dims, x))) + if (!all_equal) { + stop("Parameter 'data' variables need to have the same dimensions.") + } + # lat + if (!is.numeric(lat)) { + stop("Parameter 'lat' must be numeric.") + } + if (!lat_dim %in% names(dims[[1]])) { + stop("Parameter 'data' must have 'lat_dim' dimension.") + } + if (any(sapply(dims, FUN = function(x) x[lat_dim] != length(lat)))) { + stop("Parameter 'lat' needs to have the same length of latitudinal", + "dimension of all the variables arrays in 'data'.") + } + + # data (2) + if (all(c('tmin', 'tmax', 'pr') %in% names(data))) { + # hargreaves modified: 'tmin', 'tmax', 'pr' and 'lat' + if (!(pet_method %in% c('hargreaves_modified', 'hargreaves'))) { + warning("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves_modified'.") + pet_method <- 'hargreaves_modified' + } + } else if (all(c('tmin', 'tmax') %in% names(data))) { + if (!(pet_method %in% c('hargreaves'))) { + warning("Parameter 'pet_method' will be set as 'hargreaves'.") + pet_method <- 'hargreaves' + } + } else if (c('tmean') %in% names(data)) { + # thornthwaite: 'tmean' (mean), 'lat' + if (!(pet_method == 'thornthwaite')) { + warning("Parameter 'pet_method' it is set to be 'thornthwaite'.") + pet_method <- 'thornthwaite' + } + } else { + stop("Parameter 'data' needs to be a named list with accepted ", + "variable names. See documentation.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!all(sapply(data, function(x) time_dim %in% names(dim(x))))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + ## leadtime_dim + if (!is.character(leadtime_dim) | length(leadtime_dim) != 1) { + stop("Parameter 'leadtime_dim' must be a character string.") + } + if (!all(sapply(data, function(x) leadtime_dim %in% names(dim(x))))) { + stop("Parameter 'leadtime_dim' is not found in 'data' dimension.") + } + ## lat_dim + if (!is.character(lat_dim) | length(lat_dim) != 1) { + stop("Parameter 'lat_dim' must be a character string.") + } + if (!all(sapply(data, function(x) lat_dim %in% names(dim(x))))) { + stop("Parameter 'lat_dim' is not found in 'data' dimension.") + } + # dates + if (is.null(dates)) { + stop("Parameter 'dates' is missing, dates must be provided.") + } + if (!any(inherits(dates, 'Date'), inherits(dates, 'POSIXct'))) { + stop("Parameter 'dates' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!time_dim %in% names(dim(dates)) | !leadtime_dim %in% names(dim(dates))) { + stop("Parameter 'dates' must have 'time_dim' and 'leadtime_dim' ", + "dimension.") + } + if (!all(dim(data[[1]])[c(time_dim, leadtime_dim)] == + dim(dates)[c(time_dim, leadtime_dim)])) { + stop("Parameter 'dates' needs to have the same length as 'time_dim' ", + "and 'leadtime_dim' as 'data'.") + } + ## na.rm + if (!is.logical(na.rm) | length(na.rm) > 1) { + stop("Parameter 'na.rm' must be one logical value.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + # complete dates + mask_dates <- .datesmask(dates, frequency = 'monthly') + lat_mask <- array(lat, dim = c(1, length(lat))) + names(dim(lat_mask)) <- c('dat', lat_dim) + + # extract mask of NA locations to return to NA the final result + mask_na <- array(1, dim = dim(data[[1]])) + if (pet_method == 'hargreaves') { + varnames <- c('tmax', 'tmin') + mask_na[which(is.na(data$tmax))] <- 0 + mask_na[which(is.na(data$tmin))] <- 0 + } else if (pet_method == 'hargreaves_modified') { + varnames <- c('tmax', 'tmin', 'pr') + mask_na[which(is.na(data$tmax))] <- 0 + mask_na[which(is.na(data$tmin))] <- 0 + mask_na[which(is.na(data$pr))] <- 0 + } else if (pet_method == 'thornthwaite') { + varnames <- c('tmean') + mask_na[which(is.na(data$tmean))] <- 0 + } + + # replace NA with 0 + for (dd in 1:length(data)) { + data[[dd]][which(is.na(data[[dd]]))] <- 0 + } + + # prepare data + target_dims_data <- lapply(data[varnames], function(x) rep(c(leadtime_dim, time_dim), 1)) + pet <- Apply(data = c(list(lat_mask = lat_mask), data[varnames]), + target_dims = c(list(lat_mask = 'dat'), target_dims_data), + fun = .pet, + mask_dates = mask_dates, pet_method = pet_method, + leadtime_dim = leadtime_dim, time_dim = time_dim, + output_dims = c(leadtime_dim, time_dim), + ncores = ncores)$output1 + # reorder dims in pet_estimated + pos <- match(names(dim(data[[1]])), names(dim(pet))) + pet <- aperm(pet, pos) + + # restore original NAs from mask_na + pet[which(mask_na == 0)] <- NA + + return(pet) +} + +.pet <- function(lat_mask, data2, data3 = NULL, data4 = NULL, + mask_dates, pet_method = 'hargreaves', + leadtime_dim = 'time', time_dim = 'syear') { + + dims <- dim(data2) + + # create a vector from data but adding 0 to achive complete time series + # of the considered period + # (starting in January of the first year) so that the solar radiation + # estimation is computed in each case for the correct month + + if (!is.null(data2)) { + data_tmp <- as.vector(data2) + data2 <- array(0, dim = length(mask_dates)) + count <- 1 + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { + data2[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (!is.null(data3)) { + data_tmp <- as.vector(data3) + data3 <- array(0, dim = length(mask_dates)) + count <- 1 + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { + data3[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (!is.null(data4)) { + data_tmp <- as.vector(data4) + data4 <- array(0, dim = length(mask_dates)) + count <- 1 + for (dd in 1:length(mask_dates)) { + if (mask_dates[dd] == 1) { + data4[dd] <- data_tmp[count] + count <- count + 1 + } + } + rm(data_tmp) + } + if (pet_method == 'hargreaves') { + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, na.rm = FALSE, verbose = FALSE) + # line to return the vector to the size of the actual original data + pet <- array(pet[which(mask_dates == 1)], dim = dims) + } + + if (pet_method == 'hargreaves_modified') { + pet <- hargreaves(Tmin = as.vector(data3), Tmax = as.vector(data2), + lat = lat_mask, Pre = as.vector(data4), na.rm = FALSE, + verbose = FALSE) + pet <- array(pet[which(mask_dates == 1)], dim = dims) + } + + if (pet_method == 'thornthwaite') { + pet <- thornthwaite(as.vector(data2), lat = lat_mask, na.rm = TRUE, + verbose = FALSE) + # line to return the vector to the size of the actual original data + pet <- array(pet[which(mask_dates == 1)], dim = dims) + } + return(pet) +} \ No newline at end of file diff --git a/R/PeriodStandardization.R b/R/PeriodStandardization.R new file mode 100644 index 0000000000000000000000000000000000000000..6ab707e713174dc8ebb41ce8fce3e240946bd05f --- /dev/null +++ b/R/PeriodStandardization.R @@ -0,0 +1,646 @@ +#'Compute the Standardization of Precipitation-Evapotranspiration Index +#' +#'The Standardization of the data is the last step of computing the SPEI +#'(Standarized Precipitation-Evapotranspiration Index). With this function the +#'data is fit to a probability distribution to transform the original values to +#'standardized units that are comparable in space and time and at different SPEI +#'time scales. +#' +#'Next, some specifications for the calculation of the standardization will be +#'discussed. If there are NAs in the data and they are not removed with the +#'parameter 'na.rm', the standardization cannot be carried out for those +#'coordinates and therefore, the result will be filled with NA for the +#'specific coordinates. When NAs are not removed, if the length of the data for +#'a computational step is smaller than 4, there will not be enough data for +#'standarize and the result will be also filled with NAs for that coordinates. +#'About the distribution used to fit the data, there are only two possibilities: +#''log-logistic' and 'Gamma'. The 'Gamma' method only works when only +#'precipitation is provided and other variables are 0 because it is positive +#'defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +#'standardization is computed with cross validation. This function is build to +#'be compatible with other tools in that work with 's2dv_cube' object +#'class. The input data must be this object class. If you don't work with +#''s2dv_cube', see PeriodStandardization. For more information on the SPEI +#'indicator calculation, see CST_PeriodPET and CST_PeriodAccumulation. +#' +#'@param data An 's2dv_cube' that element 'data' stores a multidimensional +#' array containing the data to be standardized. +#'@param data_cor An 's2dv_cube' that element 'data' stores a multidimensional +#' array containing the data in which the standardization should be applied +#' using the fitting parameters from 'data'. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param memb_dim A character string indicating the name of the dimension in +#' which the ensemble members are stored. When set it to NULL, threshold is +#' computed for individual members. +#'@param ref_period A list with two numeric values with the starting and end +#' points of the reference period used for computing the index. The default +#' value is NULL indicating that the first and end values in data will be +#' used as starting and end points. +#'@param params An optional parameter that needs to be a multidimensional array +#' with named dimensions. This option overrides computation of fitting +#' parameters. It needs to be of same time dimensions (specified in 'time_dim' +#' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +#' of the coefficients needed for the used distribution (for 'Gamma' coef +#' dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +#' to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +#' will only be used if 'data_cor' is not provided. +#'@param handle_infinity A logical value wether to return infinite values (TRUE) +#' or not (FALSE). When it is TRUE, the positive infinite values (negative +#' infinite) are substituted by the maximum (minimum) values of each +#' computation step, a subset of the array of dimensions time_dim, leadtime_dim +#' and memb_dim. +#'@param method A character string indicating the standardization method used. +#' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +#' default. +#'@param distribution A character string indicating the name of the distribution +#' function to be used for computing the SPEI. The accepted names are: +#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +#' 'Gamma' method only works when only precipitation is provided and other +#' variables are 0 because it is positive defined (SPI indicator). +#'@param return_params A logical value indicating wether to return parameters +#' array (TRUE) or not (FALSE). It is FALSE by default. +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. If it is FALSE and there are NA values, +#' standardization cannot be carried out for those coordinates and therefore, +#' the result will be filled with NA for the specific coordinates. If it is +#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is +#' not reaching 4 values, it is not enough values to estimate the parameters +#' and the result will include NA. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@return An object of class \code{s2dv_cube} containing the standardized data. +#'If 'data_cor' is provided the array stored in element data will be of the same +#'dimensions as 'data_cor'. If 'data_cor' is not provided, the array stored in +#'element data will be of the same dimensions as 'data'. The parameters of the +#'standardization will only be returned if 'return_params' is TRUE, in this +#'case, the output will be a list of two objects one for the standardized data +#'and one for the parameters. +#' +#'@examples +#'dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) +#'data <- NULL +#'data$data <- array(rnorm(600, -204.1, 78.1), dim = dims) +#'class(data) <- 's2dv_cube' +#'SPEI <- CST_PeriodStandardization(data = data) +#'@export +CST_PeriodStandardization <- function(data, data_cor = NULL, time_dim = 'syear', + leadtime_dim = 'time', memb_dim = 'ensemble', + ref_period = NULL, + handle_infinity = FALSE, + method = 'parametric', + distribution = 'log-Logistic', + params = NULL, return_params = FALSE, + na.rm = FALSE, ncores = NULL) { + # Check 's2dv_cube' + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of 's2dv_cube' class.") + } + if (!is.null(data_cor)) { + if (!inherits(data_cor, 's2dv_cube')) { + stop("Parameter 'data_cor' must be of 's2dv_cube' class.") + } + } + res <- PeriodStandardization(data = data$data, data_cor = data_cor$data, + time_dim = time_dim, leadtime_dim = leadtime_dim, + memb_dim = memb_dim, + ref_period = ref_period, + handle_infinity = handle_infinity, method = method, + distribution = distribution, + params = params, return_params = return_params, + na.rm = na.rm, ncores = ncores) + if (return_params) { + std <- res$spei + params <- res$params + } else { + std <- res + } + + if (is.null(data_cor)) { + data$data <- std + data$attrs$Variable$varName <- paste0(data$attrs$Variable$varName, ' standardized') + if (return_params) { + return(list(spei = data, params = params)) + } else { + return(data) + } + } else { + data_cor$data <- std + data_cor$attrs$Variable$varName <- paste0(data_cor$attrs$Variable$varName, ' standardized') + data_cor$attrs$Datasets <- c(data_cor$attrs$Datasets, data$attrs$Datasets) + data_cor$attrs$source_files <- c(data_cor$attrs$source_files, data$attrs$source_files) + return(data_cor) + } +} + +#'Compute the Standardization of Precipitation-Evapotranspiration Index +#' +#'The Standardization of the data is the last step of computing the SPEI +#'indicator. With this function the data is fit to a probability distribution to +#'transform the original values to standardized units that are comparable in +#'space and time and at different SPEI time scales. +#' +#'Next, some specifications for the calculation of the standardization will be +#'discussed. If there are NAs in the data and they are not removed with the +#'parameter 'na.rm', the standardization cannot be carried out for those +#'coordinates and therefore, the result will be filled with NA for the +#'specific coordinates. When NAs are not removed, if the length of the data for +#'a computational step is smaller than 4, there will not be enough data for +#'standarize and the result will be also filled with NAs for that coordinates. +#'About the distribution used to fit the data, there are only two possibilities: +#''log-logistic' and 'Gamma'. The 'Gamma' method only works when only +#'precipitation is provided and other variables are 0 because it is positive +#'defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +#'standardization is computed with cross validation. For more information about +#'SPEI, see functions PeriodPET and PeriodAccumulation. +#' +#'@param data A multidimensional array containing the data to be standardized. +#'@param data_cor A multidimensional array containing the data in which the +#' standardization should be applied using the fitting parameters from 'data'. +#'@param dates An array containing the dates of the data with the same time +#' dimensions as the data. It is optional and only necessary for using the +#' parameter 'ref_period' to select a reference period directly from dates. +#'@param time_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'syear'. +#'@param leadtime_dim A character string indicating the name of the temporal +#' dimension. By default, it is set to 'time'. +#'@param memb_dim A character string indicating the name of the dimension in +#' which the ensemble members are stored. When set it to NULL, threshold is +#' computed for individual members. +#'@param ref_period A list with two numeric values with the starting and end +#' points of the reference period used for computing the index. The default +#' value is NULL indicating that the first and end values in data will be +#' used as starting and end points. +#'@param params An optional parameter that needs to be a multidimensional array +#' with named dimensions. This option overrides computation of fitting +#' parameters. It needs to be of same time dimensions (specified in 'time_dim' +#' and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +#' of the coefficients needed for the used distribution (for 'Gamma' coef +#' dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +#' to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +#' will only be used if 'data_cor' is not provided. +#'@param handle_infinity A logical value wether to return infinite values (TRUE) +#' or not (FALSE). When it is TRUE, the positive infinite values (negative +#' infinite) are substituted by the maximum (minimum) values of each +#' computation step, a subset of the array of dimensions time_dim, leadtime_dim +#' and memb_dim. +#'@param method A character string indicating the standardization method used. +#' If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +#' default. +#'@param distribution A character string indicating the name of the distribution +#' function to be used for computing the SPEI. The accepted names are: +#' 'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +#' 'Gamma' method only works when only precipitation is provided and other +#' variables are 0 because it is positive defined (SPI indicator). +#'@param return_params A logical value indicating wether to return parameters +#' array (TRUE) or not (FALSE). It is FALSE by default. +#'@param na.rm A logical value indicating whether NA values should be removed +#' from data. It is FALSE by default. If it is FALSE and there are NA values, +#' standardization cannot be carried out for those coordinates and therefore, +#' the result will be filled with NA for the specific coordinates. If it is +#' TRUE, if the data from other dimensions except time_dim and leadtime_dim is +#' not reaching 4 values, it is not enough values to estimate the parameters +#' and the result will include NA. +#'@param ncores An integer value indicating the number of cores to use in +#' parallel computation. +#' +#'@return A multidimensional array containing the standardized data. +#'If 'data_cor' is provided the array will be of the same dimensions as +#''data_cor'. If 'data_cor' is not provided, the array will be of the same +#'dimensions as 'data'. The parameters of the standardization will only be +#'returned if 'return_params' is TRUE, in this case, the output will be a list +#'of two objects one for the standardized data and one for the parameters. +#' +#'@examples +#'dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) +#'dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) +#'data <- array(rnorm(600, -194.5, 64.8), dim = dims) +#'datacor <- array(rnorm(100, -217.8, 68.29), dim = dimscor) +#' +#'SPEI <- PeriodStandardization(data = data) +#'SPEIcor <- PeriodStandardization(data = data, data_cor = datacor) +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@importFrom lmomco pwm.pp pwm.ub pwm2lmom are.lmom.valid parglo pargam parpe3 +#'@importFrom lmom cdfglo cdfgam cdfpe3 pelglo pelgam pelpe3 +#'@importFrom SPEI parglo.maxlik +#'@importFrom stats qnorm sd window +#'@export +PeriodStandardization <- function(data, data_cor = NULL, dates = NULL, + time_dim = 'syear', leadtime_dim = 'time', + memb_dim = 'ensemble', + ref_period = NULL, handle_infinity = FALSE, + method = 'parametric', + distribution = 'log-Logistic', + params = NULL, return_params = FALSE, + na.rm = FALSE, ncores = NULL) { + # Check inputs + ## data + if (!is.array(data)) { + stop("Parameter 'data' must be a numeric array.") + } + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have dimension names.") + } + ## data_cor + if (!is.null(data_cor)) { + if (!is.array(data_cor)) { + stop("Parameter 'data_cor' must be a numeric array.") + } + if (is.null(names(dim(data_cor)))) { + stop("Parameter 'data_cor' must have dimension names.") + } + } + ## dates + if (!is.null(dates)) { + if (!any(inherits(dates, 'Date'), inherits(dates, 'POSIXct'))) { + stop("Parameter 'dates' is not of the correct class, ", + "only 'Date' and 'POSIXct' classes are accepted.") + } + if (!time_dim %in% names(dim(dates)) | !leadtime_dim %in% names(dim(dates))) { + stop("Parameter 'dates' must have 'time_dim' and 'leadtime_dim' ", + "dimension.") + } + if (dim(data)[c(time_dim)] != dim(dates)[c(time_dim)]) { + stop("Parameter 'dates' needs to have the same length of 'time_dim' ", + "as 'data'.") + } + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + if (!is.null(data_cor)) { + if (!time_dim %in% names(dim(data_cor))) { + stop("Parameter 'time_dim' is not found in 'data_cor' dimension.") + } + } + ## leadtime_dim + if (!is.character(leadtime_dim) | length(leadtime_dim) != 1) { + stop("Parameter 'leadtime_dim' must be a character string.") + } + if (!leadtime_dim %in% names(dim(data))) { + stop("Parameter 'leadtime_dim' is not found in 'data' dimension.") + } + if (!is.null(data_cor)) { + if (!leadtime_dim %in% names(dim(data_cor))) { + stop("Parameter 'leadtime_dim' is not found in 'data_cor' dimension.") + } + } + ## memb_dim + if (!is.character(memb_dim) | length(memb_dim) != 1) { + stop("Parameter 'memb_dim' must be a character string.") + } + if (!memb_dim %in% names(dim(data))) { + stop("Parameter 'memb_dim' is not found in 'data' dimension.") + } + if (!is.null(data_cor)) { + if (!memb_dim %in% names(dim(data_cor))) { + stop("Parameter 'memb_dim' is not found in 'data_cor' dimension.") + } + } + ## data_cor (2) + if (!is.null(data_cor)) { + if (dim(data)[leadtime_dim] != dim(data_cor)[leadtime_dim]) { + stop("Parameter 'data' and 'data_cor' have dimension 'leadtime_dim' ", + "of different length.") + } + } + ## ref_period + if (!is.null(ref_period)) { + years_dates <- format(dates, "%Y") + if (is.null(dates)) { + warning("Parameter 'dates' is not provided so 'ref_period' can't be ", + "used.") + ref_period <- NULL + } else if (length(ref_period) != 2) { + warning("Parameter 'ref_period' must be of length two indicating the ", + "first and end years of the reference period. It will not ", + "be used.") + ref_period <- NULL + } else if (!all(sapply(ref_period, is.numeric))) { + warning("Parameter 'ref_period' must be a numeric vector indicating the ", + "'start' and 'end' years of the reference period. It will not ", + "be used.") + ref_period <- NULL + } else if (ref_period[[1]] > ref_period[[2]]) { + warning("In parameter 'ref_period' 'start' cannot be after 'end'. It ", + "will not be used.") + ref_period <- NULL + } else if (!all(unlist(ref_period) %in% years_dates)) { + warning("Parameter 'ref_period' contain years outside the dates. ", + "It will not be used.") + ref_period <- NULL + } else { + years <- format(Subset(dates, along = leadtime_dim, indices = 1), "%Y") + ref_period[[1]] <- which(ref_period[[1]] == years) + ref_period[[2]] <- which(ref_period[[2]] == years) + } + } + ## handle_infinity + if (!is.logical(handle_infinity)) { + stop("Parameter 'handle_infinity' must be a logical value.") + } + ## method + if (!(method %in% c('parametric', 'non-parametric'))) { + stop("Parameter 'method' must be a character string containing one of ", + "the following methods: 'parametric' or 'non-parametric'.") + } + ## distribution + if (!(distribution %in% c('log-Logistic', 'Gamma', 'PearsonIII'))) { + stop("Parameter 'distribution' must be a character string containing one ", + "of the following distributions: 'log-Logistic', 'Gamma' or ", + "'PearsonIII'.") + } + ## params + if (!is.null(params)) { + if (!is.numeric(params)) { + stop("Parameter 'params' must be numeric.") + } + if (!all(c(time_dim, leadtime_dim, 'coef') %in% names(dim(params)))) { + stop("Parameter 'params' must be a multidimensional array with named ", + "dimensions: '", time_dim, "', '", leadtime_dim, "' and 'coef'.") + } + dims_data <- dim(data)[-which(names(dim(data)) == memb_dim)] + dims_params <- dim(params)[-which(names(dim(params)) == 'coef')] + if (!all(dims_data == dims_params)) { + stop("Parameter 'data' and 'params' must have same common dimensions ", + "except 'memb_dim' and 'coef'.") + } + + if (distribution == "Gamma") { + if (dim(params)['coef'] != 2) { + stop("For '", distribution, "' distribution, params array should have ", + "'coef' dimension of length 2.") + } + } else { + if (dim(params)['coef'] != 3) { + stop("For '", distribution, "' distribution, params array should have ", + "'coef' dimension of length 3.") + } + } + } + ## return_params + if (!is.logical(return_params)) { + stop("Parameter 'return_params' must be logical.") + } + ## na.rm + if (!is.logical(na.rm)) { + stop("Parameter 'na.rm' must be logical.") + } + ## ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | any(ncores %% 1 != 0) | any(ncores < 0) | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + + if (is.null(ref_period)) { + ref_start <- NULL + ref_end <- NULL + } else { + ref_start <- ref_period[[1]] + ref_end <- ref_period[[2]] + } + + # Standardization + if (is.null(data_cor)) { + if (is.null(params)) { + res <- Apply(data = list(data), + target_dims = c(leadtime_dim, time_dim, memb_dim), + fun = .standardization, data_cor = NULL, params = NULL, + leadtime_dim = leadtime_dim, time_dim = time_dim, + ref_start = ref_start, ref_end = ref_end, + handle_infinity = handle_infinity, + method = method, distribution = distribution, + return_params = return_params, + na.rm = na.rm, ncores = ncores) + } else { + res <- Apply(data = list(data = data, params = params), + target_dims = list(data = c(leadtime_dim, time_dim, memb_dim), + params = c(leadtime_dim, time_dim, 'coef')), + fun = .standardization, data_cor = NULL, + leadtime_dim = leadtime_dim, time_dim = time_dim, + ref_start = ref_start, ref_end = ref_end, + handle_infinity = handle_infinity, + method = method, distribution = distribution, + return_params = return_params, + na.rm = na.rm, ncores = ncores) + } + } else { + res <- Apply(data = list(data = data, data_cor = data_cor), + target_dims = c(leadtime_dim, time_dim, memb_dim), + fun = .standardization, params = NULL, + leadtime_dim = leadtime_dim, time_dim = time_dim, + ref_start = ref_start, ref_end = ref_end, + handle_infinity = handle_infinity, + method = method, distribution = distribution, + return_params = return_params, + na.rm = na.rm, ncores = ncores) + } + if (return_params) { + spei <- res$spei + params <- res$params + } else { + spei <- res$output1 + } + + if (is.null(data_cor)) { + pos <- match(names(dim(data)), names(dim(spei))) + spei <- aperm(spei, pos) + } else { + pos <- match(names(dim(data_cor)), names(dim(spei))) + spei <- aperm(spei, pos) + } + + if (return_params) { + pos <- match(c(names(dim(spei))[-which(names(dim(spei)) == memb_dim)], 'coef'), + names(dim(params))) + params <- aperm(params, pos) + return(list('spei' = spei, 'params' = params)) + } else { + return(spei) + } +} + +.standardization <- function(data, data_cor = NULL, params = NULL, + leadtime_dim = 'time', time_dim = 'syear', + ref_start = NULL, ref_end = NULL, handle_infinity = FALSE, + method = 'parametric', distribution = 'log-Logistic', + return_params = FALSE, na.rm = FALSE) { + # data (data_cor): [leadtime_dim, time_dim, memb_dim] + dims <- dim(data)[-1] + fit = 'ub-pwm' + + coef = switch(distribution, + "Gamma" = array(NA, dim = 2, dimnames = list(c('alpha', 'beta'))), + "log-Logistic" = array(NA, dim = 3, dimnames = list(c('xi', 'alpha', 'kappa'))), + "PearsonIII" = array(NA, dim = 3, dimnames = list(c('mu', 'sigma', 'gamma')))) + + if (is.null(data_cor)) { + # cross_val = TRUE + spei_mod <- data*NA + if (return_params) { + params_result <- array(dim = c(dim(data)[-length(dim(data))], coef = length(coef))) + } + for (ff in 1:dim(data)[leadtime_dim]) { + data2 <- data[ff, , ] + dim(data2) <- dims + if (method == 'non-parametric') { + bp <- matrix(0, length(data2), 1) + for (i in 1:length(data2)) { + bp[i,1] = sum(data2[] <= data2[i], na.rm = na.rm); # Writes the rank of the data + } + std_index <- qnorm((bp - 0.44)/(length(data2) + 0.12)) + dim(std_index) <- dims + spei_mod[ff, , ] <- std_index + } else { + if (!is.null(ref_start) && !is.null(ref_end)) { + data_fit <- window(data2, ref_start, ref_end) + } else { + data_fit <- data2 + } + for (nsd in 1:dim(data)[time_dim]) { + if (is.null(params)) { + acu <- as.vector(data_fit[-nsd, ]) + if (na.rm) { + acu_sorted <- sort.default(acu, method = "quick") + } else { + acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) + } + f_params <- NA + if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { + acu_sd <- sd(acu_sorted) + if (!is.na(acu_sd) & acu_sd != 0) { + if (distribution != "log-Logistic") { + acu_sorted <- acu_sorted[acu_sorted > 0] + } + if (length(acu_sorted) >= 4) { + f_params <- .std(data = acu_sorted, fit = fit, + distribution = distribution) + } + } + } + } else { + f_params <- params[ff, nsd, ] + } + if (all(is.na(f_params))) { + cdf_res <- NA + } else { + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data2, f_params), + "Gamma" = lmom::cdfgam(data2, f_params), + "PearsonIII" = lmom::cdfpe3(data2, f_params)) + } + std_index_cv <- array(qnorm(cdf_res), dim = dims) + spei_mod[ff, nsd, ] <- std_index_cv[nsd, ] + if (return_params) params_result[ff, nsd, ] <- f_params + } + } + } + } else { + # cross_val = FALSE + spei_mod <- data_cor*NA + dimscor <- dim(data_cor)[-1] + if (return_params) { + params_result <- array(dim = c(dim(data_cor)[-length(dim(data_cor))], coef = length(coef))) + } + for (ff in 1:dim(data)[leadtime_dim]) { + data_cor2 <- data_cor[ff, , ] + dim(data_cor2) <- dimscor + if (method == 'non-parametric') { + bp <- matrix(0, length(data_cor2), 1) + for (i in 1:length(data_cor2)) { + bp[i,1] = sum(data_cor2[] <= data_cor2[i], na.rm = na.rm); # Writes the rank of the data + } + std_index <- qnorm((bp - 0.44)/(length(data_cor2) + 0.12)) + dim(std_index) <- dimscor + spei_mod[ff, , ] <- std_index + } else { + data2 <- data[ff, , ] + dim(data2) <- dims + if (!is.null(ref_start) && !is.null(ref_end)) { + data_fit <- window(data2, ref_start, ref_end) + } else { + data_fit <- data2 + } + acu <- as.vector(data_fit) + if (na.rm) { + acu_sorted <- sort.default(acu, method = "quick") + } else { + acu_sorted <- sort.default(acu, method = "quick", na.last = TRUE) + } + if (!any(is.na(acu_sorted)) & length(acu_sorted) != 0) { + acu_sd <- sd(acu_sorted) + if (!is.na(acu_sd) & acu_sd != 0) { + if (distribution != "log-Logistic") { + acu_sorted <- acu_sorted[acu_sorted > 0] + } + if (length(acu_sorted) >= 4) { + f_params <- .std(data = acu_sorted, fit = fit, + distribution = distribution) + } + if (all(is.na(f_params))) { + cdf_res <- NA + } else { + f_params <- f_params[which(!is.na(f_params))] + cdf_res = switch(distribution, + "log-Logistic" = lmom::cdfglo(data_cor2, f_params), + "Gamma" = lmom::cdfgam(data_cor2, f_params), + "PearsonIII" = lmom::cdfpe3(data_cor2, f_params)) + } + std_index_cv <- array(qnorm(cdf_res), dim = dimscor) + spei_mod[ff, , ] <- std_index_cv + if (return_params) params_result[ff, , ] <- f_params + } + } + } + } + } + if (handle_infinity) { + # could also use "param_error" ?; we are giving it the min/max value of the grid point + spei_mod[is.infinite(spei_mod) & spei_mod < 0] <- min(spei_mod[!is.infinite(spei_mod)]) + spei_mod[is.infinite(spei_mod) & spei_mod > 0] <- max(spei_mod[!is.infinite(spei_mod)]) + } + if (return_params) { + return(list(spei = spei_mod, params = params_result)) + } else { + return(spei_mod) + } +} + +.std <- function(data, fit = 'pp-pwm', distribution = 'log-Logistic') { + pwm = switch(fit, + 'pp-pwm' = lmomco::pwm.pp(data, -0.35, 0, nmom = 3), + lmomco::pwm.ub(data, nmom = 3) + # TLMoments::PWM(data, order = 0:2) + ) + lmom <- lmomco::pwm2lmom(pwm) + if (!any(!lmomco::are.lmom.valid(lmom), anyNA(lmom[[1]]), any(is.nan(lmom[[1]])))) { + fortran_vec = c(lmom$lambdas[1:2], lmom$ratios[3]) + params_result = switch(distribution, + 'log-Logistic' = tryCatch(lmom::pelglo(fortran_vec), + error = function(e){lmomco::parglo(lmom)$para}), + 'Gamma' = tryCatch(lmom::pelgam(fortran_vec), + error = function(e){lmomco::pargam(lmom)$para}), + 'PearsonIII' = tryCatch(lmom::pelpe3(fortran_vec), + error = function(e){lmomco::parpe3(lmom)$para})) + if (distribution == 'log-Logistic' && fit == 'max-lik') { + params_result = SPEI::parglo.maxlik(data, params_result)$para + } + return(params_result) + } else { + return(NA) + } +} \ No newline at end of file diff --git a/R/PeriodVariance.R b/R/PeriodVariance.R new file mode 100644 index 0000000000000000000000000000000000000000..4e1e93e89181fe40b8aa903ec4df8d7fd6a371f4 --- /dev/null +++ b/R/PeriodVariance.R @@ -0,0 +1,227 @@ +#'Period Variance on 's2dv_cube' objects +#' +#'Period Variance computes the average (var) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item{'BIO4', (Providing temperature data) Temperature Seasonality +#' (Standard Deviation). The amount of temperature variation +#' over a given year (or averaged years) based on the standard +#' deviation (variation) of monthly temperature averages.} +#' \item{'BIO15', (Providing precipitation data) Precipitation Seasonality +#' (CV). This is a measure of the variation in monthly precipitation +#' totals over the course of the year. This index is the ratio of the +#' standard deviation of the monthly total precipitation to the mean +#' monthly total precipitation (also known as the coefficient of +#' variation) and is expressed as a percentage.} +#'} +#' +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'time'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return An 's2dv_cube' object containing the indicator in the element +#'\code{data} with dimensions of the input parameter 'data' except the +#'dimension where the var has been computed (specified with 'time_dim'). A new +#'element called 'time_bounds' will be added into the 'attrs' element in the +#''s2dv_cube' object. It consists of a list containing two elements, the start +#'and end dates of the aggregated period with the same dimensions of 'Dates' +#'element. +#' +#'@examples +#'exp <- NULL +#'exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'exp$attrs$Dates <- Dates +#'class(exp) <- 's2dv_cube' +#' +#'res <- CST_PeriodVariance(exp, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@importFrom ClimProjDiags Subset +#'@export +CST_PeriodVariance <- function(data, start = NULL, end = NULL, + time_dim = 'time', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") + } + + # Dates subset + if (!is.null(start) && !is.null(end)) { + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL + } + } + + Dates <- data$attrs$Dates + total <- PeriodVariance(data = data$data, dates = Dates, start = start, end = end, + time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + data$data <- total + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } + } + return(data) +} + +#'Period Variance on multidimensional array objects +#' +#'Period Variance computes the average (var) of a given variable in a period. +#'Two bioclimatic indicators can be obtained by using this function: +#'\itemize{ +#' \item{'BIO4', (Providing temperature data) Temperature Seasonality +#' (Standard Deviation). The amount of temperature variation +#' over a given year (or averaged years) based on the standard +#' deviation (variation) of monthly temperature averages.} +#' \item{'BIO15', (Providing precipitation data) Precipitation Seasonality +#' (CV). This is a measure of the variation in monthly precipitation +#' totals over the course of the year. This index is the ratio of the +#' standard deviation of the monthly total precipitation to the mean +#' monthly total precipitation (also known as the coefficient of +#' variation) and is expressed as a percentage.} +#'} +#' +#'@param data A multidimensional array with named dimensions. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. +#'@param start An optional parameter to defined the initial date of the period +#' to select from the data by providing a list of two elements: the initial +#' date of the period and the initial month of the period. By default it is set +#' to NULL and the indicator is computed using all the data provided in +#' \code{data}. +#'@param end An optional parameter to defined the final date of the period to +#' select from the data by providing a list of two elements: the final day of +#' the period and the final month of the period. By default it is set to NULL +#' and the indicator is computed using all the data provided in \code{data}. +#'@param time_dim A character string indicating the name of the dimension to +#' compute the indicator. By default, it is set to 'time'. More than one +#' dimension name matching the dimensions provided in the object +#' \code{data$data} can be specified. +#'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or +#' not (FALSE). +#'@param ncores An integer indicating the number of cores to use in parallel +#' computation. +#' +#'@return A multidimensional array with named dimensions containing the +#'indicator in the element \code{data}. +#' +#'@examples +#'data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +#'Dates <- c(seq(as.Date("2000-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2001-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2001-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2002-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2002-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2003-01-01", "%Y-%m-%d", tz = "UTC"), by = "month"), +#' seq(as.Date("2003-11-01", "%Y-%m-%d", tz = "UTC"), +#' as.Date("2004-01-01", "%Y-%m-%d", tz = "UTC"), by = "month")) +#'dim(Dates) <- c(sdate = 4, time = 3) +#'res <- PeriodVariance(data, dates = Dates, start = list(01, 12), end = list(01, 01)) +#' +#'@import multiApply +#'@export +PeriodVariance <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { + # Initial checks + ## data + if (is.null(data)) { + stop("Parameter 'data' cannot be NULL.") + } + if (!is.numeric(data)) { + stop("Parameter 'data' must be numeric.") + } + ## time_dim + if (!is.character(time_dim) | length(time_dim) != 1) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!is.array(data)) { + dim(data) <- length(data) + names(dim(data)) <- time_dim + } + if (!time_dim %in% names(dim(data))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { + if (!any(c(is.list(start), is.list(end)))) { + stop("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } + } + } + total <- Apply(list(data), target_dims = time_dim, + fun = .periodvariance, + na.rm = na.rm, ncores = ncores)$output1 + return(total) +} + +.periodvariance <- function(data, na.rm) { + var <- sum((data - mean(data, na.rm = na.rm))^2) / (length(data)-1) + return(var) +} + + diff --git a/R/QThreshold.R b/R/QThreshold.R index 49217dd20e8986ecb786d8f4232212743132a989..6bd8d83eeae4e936a9790f67bca1d015adc6a9d8 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -22,8 +22,8 @@ #' the sample used must be especified in sdate_dim parameter.} #'} #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold An 's2dv_cube' object as output of a 'CST_' function in the #' same units as parameter 'data' and with the common dimensions of the element #' 'data' of the same length. A single scalar is also possible. @@ -37,7 +37,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -54,23 +54,27 @@ #'@examples #'threshold <- 26 #'exp <- NULL -#'exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, ftime = 2)) +#'exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, time = 2)) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_QThreshold(exp, threshold) -#'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' +#'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*50), +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'exp_probs <- CST_QThreshold(exp, threshold) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) +#'class(exp) <- 's2dv_cube' +#'exp_probs <- CST_QThreshold(exp, threshold, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply #'@export CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -92,6 +96,8 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, start, end, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim, ncores = ncores) data$data <- probs + data$dims <- dim(probs) + if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, @@ -127,9 +133,9 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #'@param threshold A multidimensional array with named dimensions in the same #' units as parameter 'data' and with the common dimensions of the element #' 'data' of the same length. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -140,7 +146,7 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -157,14 +163,25 @@ CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, #'@examples #'threshold = 25 #'data <- array(rnorm(5 * 3 * 20 * 2, mean = 26), -#' c(member = 5, sdate = 3, time = 20, lon = 2)) -#'thres_q <- QThreshold(data, threshold) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) +#' +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#' +#'thres_q <- QThreshold(data, threshold, dates = Dates, time_dim = 'time', +#' start = list(21, 4), end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', - ncores = NULL) { + time_dim = 'time', memb_dim = 'member', + sdate_dim = 'sdate', ncores = NULL) { # Initial checks ## data if (is.null(data)) { @@ -202,8 +219,12 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (is.null(memb_dim)) { memb_dim <- 99999 } - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") @@ -211,7 +232,7 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (time_dim %in% names(dim(threshold))) { if (dim(threshold)[time_dim] == dim(data)[time_dim]) { if (!is.null(dim(dates)) && sdate_dim %in% names(dim(dates))) { - dates_thres <- .arraysubset(dates, dim = sdate_dim, value = 1) + dates_thres <- Subset(dates, along = sdate_dim, indices = 1) threshold <- SelectPeriodOnData(data = threshold, dates = dates_thres, start, end, time_dim = time_dim, ncores = ncores) } else { @@ -220,10 +241,16 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, } } } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } + if (length(threshold) == 1) { if (memb_dim %in% names(dim(data))) { probs <- Apply(list(data), target_dims = c(memb_dim, sdate_dim), diff --git a/R/SelectPeriodOnData.R b/R/SelectPeriodOnData.R index 94bcfe9f3daa66e63e8a3375369c279d2279a2fc..a4cc07c1e7493e44ae6c944a740e9bd1eda6de3a 100644 --- a/R/SelectPeriodOnData.R +++ b/R/SelectPeriodOnData.R @@ -2,8 +2,8 @@ #' #' Auxiliary function to subset data for a specific period. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param start A parameter to defined the initial date of the period to select #' from the data by providing a list of two elements: the initial date of the #' period and the initial month of the period. @@ -11,7 +11,7 @@ #' the data by providing a list of two elements: the final day of the period #' and the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. More than one +#' compute select the dates. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -23,19 +23,19 @@ #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +#'dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) #'class(exp) <- 's2dv_cube' #'Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) #'@import multiApply #'@export -CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', +CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -79,7 +79,7 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', #' to select from the data. The first element is the final day of the period #' and the second element is the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. Parameters +#' compute select the dates. By default, it is set to 'time'. Parameters #' 'data' and 'dates' #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -90,19 +90,20 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', #' #'@examples #'data <- array(rnorm(5 * 3 * 214 * 2), -#' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(memb = 5, sdate = 3, time = 214, lon = 2)) #'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 214, sdate = 3) +#'dim(Dates) <- c(time = 214, sdate = 3) #'Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export SelectPeriodOnData <- function(data, dates, start, end, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { if (is.null(dim(dates))) { dim(dates) <- length(dates) names(dim(dates)) <- time_dim @@ -149,11 +150,10 @@ SelectPeriodOnData <- function(data, dates, start, end, names_data <- sort(names(dim(data))) if (!all(names_res %in% names_data)) { dim_remove <- names_res[-which(names_res %in% names_data)] - res <- .arraysubset(res, dim = dim_remove, value = 1) - dim(res) <- dim(res)[-which(names(dim(res)) %in% dim_remove)] + indices <- as.list(rep(1, length(dim_remove))) + res <- Subset(res, along = dim_remove, indices, drop = 'selected') } - pos <- match(names(dim(data)), names(dim(res))) res <- aperm(res, pos) return(res) -} \ No newline at end of file +} diff --git a/R/SelectPeriodOnDates.R b/R/SelectPeriodOnDates.R index fcb1a4cb752deb02461ea33499e9e67d2efc1e7b..0919c5d0cf216b92e17e69a7028796990317654d 100644 --- a/R/SelectPeriodOnDates.R +++ b/R/SelectPeriodOnDates.R @@ -10,7 +10,7 @@ #' select from the data by providing a list of two elements: the final day of #' the period and the final month of the period. #'@param time_dim A character string indicating the name of the dimension to -#' compute select the dates. By default, it is set to 'ftime'. More than one +#' compute select the dates. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -28,11 +28,11 @@ #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) -#'dim(Dates) <- c(ftime = 214, sdate = 3) +#'dim(Dates) <- c(time = 214, sdate = 3) #'Period <- SelectPeriodOnDates(Dates, start = list(21, 6), end = list(21, 9)) #'@export SelectPeriodOnDates <- function(dates, start, end, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { if (is.null(dim(dates))) { dim(dates) <- length(dates) names(dim(dates)) <- time_dim diff --git a/R/Threshold.R b/R/Threshold.R index 3122c1289394f9e6039c2e462b1776f448a49519..314bc704e1e67cb7356804f89825e1ff3b9e729a 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -5,10 +5,10 @@ #'day (time). This function calculates the corresponding value of a percentile #'given a dataset. #' -#'@param data An 's2dv_cube' object as provided function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold A single scalar or vector indicating the relative -#' threshold(s). +#' threshold(s). It must contain values between 0 and 1. #'@param start An optional parameter to defined the initial date of the period #' to selectfrom the data by providing a list of two elements: the initial date #' of the period and the initial month of the period. By default it is set to @@ -19,7 +19,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -40,20 +40,21 @@ #'threshold <- 0.9 #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' #'exp_probs <- CST_Threshold(exp, threshold, start = list(21, 4), end = list(21, 6)) #' #'@import multiApply #'@export CST_Threshold <- function(data, threshold, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', + time_dim = 'time', memb_dim = 'member', sdate_dim = 'sdate', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' @@ -74,6 +75,10 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim, na.rm = na.rm, ncores = ncores) data$data <- thres + data$dims <- dim(thres) + data$coords[[memb_dim]] <- NULL + data$coords[[sdate_dim]] <- NULL + if (!is.null(start) && !is.null(end)) { data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, start = start, end = end, @@ -91,10 +96,10 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, #' #'@param data A multidimensional array with named dimensions. #'@param threshold A single scalar or vector indicating the relative -#' threshold(s). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#' threshold(s). It must contain values between 0 and 1. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -105,7 +110,7 @@ CST_Threshold <- function(data, threshold, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the temporal -#' dimension. By default, it is set to 'ftime'. More than one dimension name +#' dimension. By default, it is set to 'time'. More than one dimension name #' matching the dimensions provided in the object \code{data$data} can be #' specified. This dimension is required to subset the data in a requested #' period. @@ -147,7 +152,7 @@ Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, names(dim(data)) <- c(memb_dim, sdate_dim) } if (is.null(threshold)) { - stop("Parameter 'threshold' cannot be NULL.") + stop("Parameter 'threshold' cannot be NULL.") } if (!is.numeric(threshold)) { stop("Parameter 'threshold' must be numeric.") @@ -155,14 +160,24 @@ Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (is.null(names(dim(data)))) { stop("Parameter 'data' must have named dimensions.") } - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } if (!is.null(memb_dim)) { diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index 3ee22a27b21114a970476974067366adca2ffc7c..14507036558203064f334eeef869b8cc4dd51214 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -6,9 +6,9 @@ #'This function allows to compute indicators widely used in Climate Services, #'such as: #'\itemize{ -#' \code{WSDI}{Warm Spell Duration Index that count the total number of days -#' with at least 6 consecutive days when the daily temperature -#' maximum exceeds its 90th percentile.} +#' \item{'WSDI', Warm Spell Duration Index that count the total number of days +#' with at least 6 consecutive days when the daily temperature +#' maximum exceeds its 90th percentile.} #'} #'This function requires the data and the threshold to be in the same units. The #'90th percentile can be translate into absolute values given a reference dataset @@ -16,8 +16,8 @@ #'by using function \code{AbsToProbs}. See section @examples. #'@seealso [Threshold()] and [AbsToProbs()]. #' -#'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold If only one threshold is used, it can be an 's2dv_cube' #' object or a multidimensional array with named dimensions. It must be in the #' same units and with the common dimensions of the same length as parameter @@ -42,32 +42,42 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' #'@return An 's2dv_cube' object containing the number of days that are part of a -#'spell within a threshold in element \code{data}. +#'spell within a threshold in element \code{data} with dimensions of the input +#'parameter 'data' except the dimension where the indicator has been computed. +#'The 'Dates' array is updated to the dates corresponding to the beginning of +#'the aggregated time period. A new element called 'time_bounds' will be added +#'into the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' -#'TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3) +#'TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3, +#' start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', start = NULL, end = NULL, - time_dim = 'ftime', + time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -95,19 +105,42 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> threshold[[2]] <- threshold[[2]]$data } } + + Dates <- data$attrs$Dates - total <- TotalSpellTimeExceedingThreshold(data$data, data$attrs$Dates, + total <- TotalSpellTimeExceedingThreshold(data$data, Dates, threshold = threshold, spell = spell, op = op, start = start, end = end, time_dim = time_dim, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } + return(data) } #'Total Spell Time Exceeding Threshold @@ -118,9 +151,9 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'This function allows to compute indicators widely used in Climate Services, #'such as: #'\itemize{ -#' \code{WSDI}{Warm Spell Duration Index that count the total number of days -#' with at least 6 consecutive days when the daily temperature -#' maximum exceeds its 90th percentile.} +#' \item{'WSDI', Warm Spell Duration Index that count the total number of days +#' with at least 6 consecutive days when the daily temperature +#' maximum exceeds its 90th percentile.} #'} #'This function requires the data and the threshold to be in the same units. The #'90th percentile can be translate into absolute values given a reference @@ -143,9 +176,9 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #' are used it has to be a vector of a pair of two logical operators: #' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), #' c('>', '<='), c('>=', '<'),c('>=', '<=')). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -156,7 +189,7 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param ncores An integer indicating the number of cores to use in parallel #' computation. @@ -171,15 +204,25 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'values by values exceeding the threshold. #'@examples -#'data <- array(rnorm(120), c(member = 1, sdate = 2, ftime = 20, lat = 4)) -#'threshold <- array(rnorm(4), c(lat = 4)) -#'total <- TotalSpellTimeExceedingThreshold(data, threshold, spell = 6) +#'data <- array(1:100, c(member = 5, sdate = 3, time = 214, lon = 2)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#' +#'threshold <- array(1:4, c(lat = 4)) +#'total <- TotalSpellTimeExceedingThreshold(data, threshold, dates = Dates, +#' spell = 6, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply #'@export TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { # data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") @@ -311,8 +354,11 @@ TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', } } # dates - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") @@ -334,6 +380,14 @@ TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', } } } + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } data <- SelectPeriodOnData(data, dates, start, end, time_dim = time_dim, ncores = ncores) } diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index ceda1eee6ee47ef0e08ad0a1649d93e986286df2..15b822c6ee37a8aea19c9f0c12d4cd91710cde44 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -9,19 +9,19 @@ #'Providing maximum temperature daily data, the following agriculture #'indices for heat stress can be obtained by using this function: #'\itemize{ -#' \item\code{SU35}{Total count of days when daily maximum temperatures exceed -#' 35°C in the seven months from the start month given (e.g. -#' from April to October for start month of April).} -#' \item\code{SU36}{Total count of days when daily maximum temperatures exceed -#' 36 between June 21st and September 21st} -#' \item\code{SU40}{Total count of days when daily maximum temperatures exceed -#' 40 between June 21st and September 21st} -#' \item\code{Spr32}{Total count of days when daily maximum temperatures exceed -#' 32 between April 21st and June 21st} +#' \item{'SU35', Total count of days when daily maximum temperatures exceed +#' 35°C in the seven months from the start month given (e.g. from April +#' to October for start month of April).} +#' \item{'SU36', Total count of days when daily maximum temperatures exceed +#' 36 between June 21st and September 21st.} +#' \item{'SU40', Total count of days when daily maximum temperatures exceed +#' 40 between June 21st and September 21st.} +#' \item{'Spr32', Total count of days when daily maximum temperatures exceed +#' 32 between April 21st and June 21st.} #'} #' -#'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in -#' package CSTools. +#'@param data An 's2dv_cube' object as provided function \code{CST_Start} or +#' \code{CST_Load} in package CSTools. #'@param threshold If only one threshold is used, it can be an 's2dv_cube' #' object or a multidimensional array with named dimensions. It must be in the #' same units and with the common dimensions of the same length as parameter @@ -45,7 +45,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). @@ -54,26 +54,35 @@ #' #'@return An 's2dv_cube' object containing in element \code{data} the total #'number of the corresponding units of the data frequency that a variable is -#'exceeding a threshold during a period. +#'exceeding a threshold during a period with dimensions of the input parameter +#''data' except the dimension where the indicator has been computed. The +#''Dates' array is updated to the dates corresponding to the beginning of the +#'aggregated time period. A new element called 'time_bounds' will be added into +#'the 'attrs' element in the 's2dv_cube' object. It consists of a list +#'containing two elements, the start and end dates of the aggregated period with +#'the same dimensions of 'Dates' element. #' #'@examples #'exp <- NULL -#'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*280), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) +#'exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, +#' c(member = 5, sdate = 3, time = 214, lon = 2)) #'exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), #' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), #' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), #' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) #'class(exp) <- 's2dv_cube' -#'DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 280) +#'DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 23, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply +#'@importFrom ClimProjDiags Subset #'@export CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', start = NULL, end = NULL, - time_dim = 'ftime', + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { @@ -101,17 +110,39 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', threshold[[2]] <- threshold[[2]]$data } } - total <- TotalTimeExceedingThreshold(data$data, dates = data$attrs$Dates, + + Dates <- data$attrs$Dates + total <- TotalTimeExceedingThreshold(data = data$data, dates = Dates, threshold = threshold, op = op, start = start, end = end, time_dim = time_dim, na.rm = na.rm, ncores = ncores) data$data <- total - if (!is.null(start) && !is.null(end)) { - data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, - start = start, end = end, - time_dim = time_dim, - ncores = ncores) + data$dims <- dim(total) + data$coords[[time_dim]] <- NULL + + if (!is.null(Dates)) { + if (!is.null(start) && !is.null(end)) { + Dates <- SelectPeriodOnDates(dates = Dates, start = start, end = end, + time_dim = time_dim, ncores = ncores) + } + if (is.null(dim(Dates))) { + warning("Element 'Dates' has NULL dimensions. They will not be ", + "subset and 'time_bounds' will be missed.") + data$attrs$Dates <- Dates + } else { + # Create time_bounds + time_bounds <- NULL + time_bounds$start <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = 1, drop = 'selected') + time_bounds$end <- ClimProjDiags::Subset(x = Dates, along = time_dim, + indices = dim(Dates)[time_dim], + drop = 'selected') + + # Add Dates in attrs + data$attrs$Dates <- time_bounds$start + data$attrs$time_bounds <- time_bounds + } } return(data) } @@ -126,15 +157,15 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #'Providing maximum temperature daily data, the following agriculture #'indices for heat stress can be obtained by using this function: #'\itemize{ -#' \item\code{SU35}{Total count of days when daily maximum temperatures exceed -#' 35°C in the seven months from the start month given (e.g. -#' from April to October for start month of April).} -#' \item\code{SU36}{Total count of days when daily maximum temperatures exceed -#' 36 between June 21st and September 21st} -#' \item\code{SU40}{Total count of days when daily maximum temperatures exceed -#' 40 between June 21st and September 21st} -#' \item\code{Spr32}{Total count of days when daily maximum temperatures exceed -#' 32 between April 21st and June 21st} +#' \item{'SU35', Total count of days when daily maximum temperatures exceed +#' 35°C in the seven months from the start month given (e.g. from April +#' to October for start month of April).} +#' \item{'SU36', Total count of days when daily maximum temperatures exceed +#' 36 between June 21st and September 21st.} +#' \item{'SU40', Total count of days when daily maximum temperatures exceed +#' 40 between June 21st and September 21st.} +#' \item{'Spr32', Total count of days when daily maximum temperatures exceed +#' 32 between April 21st and June 21st.} #'} #' #'@param data A multidimensional array with named dimensions. @@ -151,9 +182,9 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' are used it has to be a vector of a pair of two logical operators: #' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), #' c('>', '<='), c('>=', '<'),c('>=', '<=')). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to define the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -164,7 +195,7 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. It can only +#' compute the indicator. By default, it is set to 'time'. It can only #' indicate one time dimension. #'@param na.rm A logical value indicating whether to ignore NA values (TRUE) or #' not (FALSE). @@ -173,18 +204,27 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #' #'@return A multidimensional array with named dimensions containing the total #'number of the corresponding units of the data frequency that a variable is -#'exceeding a threshold during a period. +#'exceeding a threshold during a period with dimensions of the input parameter +#''data' except the dimension where the indicator has been computed. #' #'@examples -#'exp <- array(abs(rnorm(5 * 3 * 214 * 2)*280), -#' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'DOT <- TotalTimeExceedingThreshold(exp, threshold = 300, time_dim = 'ftime') +#'data <- array(rnorm(5 * 3 * 214 * 2)*23, +#' c(member = 5, sdate = 3, time = 214, lon = 2)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#'DOT <- TotalTimeExceedingThreshold(data, threshold = 23, dates = Dates, +#' start = list(21, 4), end = list(21, 6)) #' #'@import multiApply #'@export TotalTimeExceedingThreshold <- function(data, threshold, op = '>', dates = NULL, start = NULL, end = NULL, - time_dim = 'ftime', na.rm = FALSE, + time_dim = 'time', na.rm = FALSE, ncores = NULL) { # data if (is.null(data)) { @@ -313,8 +353,11 @@ TotalTimeExceedingThreshold <- function(data, threshold, op = '>', } } # dates - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") @@ -336,8 +379,14 @@ TotalTimeExceedingThreshold <- function(data, threshold, op = '>', } } } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + data <- SelectPeriodOnData(data = data, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index 8ed20844370f7036d2cee074df64eab79308ce18..dc12fb428f6fad84942f14771e621ba4cedb6be2 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -32,7 +32,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -42,18 +42,27 @@ #'@examples #'wind <- NULL #'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), -#' c(member = 10, lat = 2, lon = 5)) +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) #'wind$coords <- list(lat = c(40, 41), lon = 1:5) #'variable <- list(varName = 'sfcWind', #' metadata = list(sfcWind = list(level = 'Surface'))) #'wind$attrs <- list(Variable = variable, Datasets = 'synthetic', #' when = Sys.time(), Dates = '1990-01-01 00:00:00') +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#'wind$attrs$Dates <- Dates #'class(wind) <- 's2dv_cube' -#'WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") +#'WCF <- CST_WindCapacityFactor(wind, IEC_class = "III", +#' start = list(21, 4), end = list(21, 6)) #' #'@export CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", "III"), - start = NULL, end = NULL, time_dim = 'ftime', + start = NULL, end = NULL, time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(wind, 's2dv_cube')) { @@ -71,8 +80,11 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II WindCapacity <- WindCapacityFactor(wind = wind$data, IEC_class = IEC_class, dates = wind$attrs$Dates, start = start, - end = end, ncores = ncores) + end = end, time_dim = time_dim, + ncores = ncores) wind$data <- WindCapacity + wind$dims <- dim(WindCapacity) + if ('Variable' %in% names(wind$attrs)) { if ('varName' %in% names(wind$attrs$Variable)) { wind$attrs$Variable$varName <- 'WindCapacityFactor' @@ -111,9 +123,9 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' respectively. Classes \code{'I/II'} and \code{'II/III'} indicate #' intermediate turbines that fit both classes. More details of the five #' turbines and a plot of its power curves can be found in Lledó et al. (2019). -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -124,7 +136,7 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -134,8 +146,19 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #' Capacity Factor (unitless). #' #'@examples -#'wind <- rweibull(n = 100, shape = 2, scale = 6) -#'WCF <- WindCapacityFactor(wind, IEC_class = "III") +#'wind <- array(rweibull(n = 32100, shape = 2, scale = 6), +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) +#' +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#' +#'WCF <- WindCapacityFactor(wind, IEC_class = "III", dates = Dates, +#' start = list(21, 4), end = list(21, 6)) #' #'@importFrom stats approxfun #'@importFrom utils read.delim @@ -153,14 +176,24 @@ WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", ) pc_file <- system.file("power_curves", pc_files[IEC_class], package = "CSIndicators", mustWork = T) pc <- read_pc(pc_file) - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - wind <- SelectPeriodOnData(wind, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + wind <- SelectPeriodOnData(data = wind, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index 357820999cb83f3c53bfdb08795d8265094026a9..4a2e51e94171d3ef81e07a9da2f80fdfe1b05981 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -6,8 +6,8 @@ #'@description It is computed as 0.5*ro*wspd^3. As this function is non-linear, #'it will give inaccurate results if used with period means. #' -#'@param wind An s2dv_cube object with instantaneous wind speeds expressed in m/s -#' obtained from CST_Load or s2dv_cube functions from CSTools pacakge. +#'@param wind An 's2dv_cube' object with instantaneous wind speeds expressed in +#' m/s obtained from CST_Start or s2dv_cube functions from CSTools pacakge. #'@param ro A scalar, or alternatively a multidimensional array with the same #' dimensions as wind, with the air density expressed in kg/m^3. By default it #' takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa. @@ -21,7 +21,7 @@ #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -32,18 +32,27 @@ #'@examples #'wind <- NULL #'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), -#' c(member = 10, lat = 2, lon = 5)) +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) #'wind$coords <- list(lat = c(40, 41), lon = 1:5) #'variable <- list(varName = 'sfcWind', #' metadata = list(sfcWind = list(level = 'Surface'))) #'wind$attrs <- list(Variable = variable, Datasets = 'synthetic', #' when = Sys.time(), Dates = '1990-01-01 00:00:00') +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#'wind$attrs$Dates <- Dates #'class(wind) <- 's2dv_cube' -#'WCF <- CST_WindPowerDensity(wind) +#'WPD <- CST_WindPowerDensity(wind, start = list(21, 4), +#' end = list(21, 6)) #' #'@export CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, - time_dim = 'ftime', ncores = NULL) { + time_dim = 'time', ncores = NULL) { # Check 's2dv_cube' if (!inherits(wind, 's2dv_cube')) { stop("Parameter 'wind' must be of the class 's2dv_cube'.") @@ -59,8 +68,10 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, } WindPower <- WindPowerDensity(wind = wind$data, ro = ro, dates = wind$attrs$Dates, start = start, - end = end, ncores = ncores) + end = end, time_dim = time_dim, + ncores = ncores) wind$data <- WindPower + wind$dims <- dim(WindPower) if ('Variable' %in% names(wind$attrs)) { if ('varName' %in% names(wind$attrs$Variable)) { wind$attrs$Variable$varName <- 'WindPowerDensity' @@ -88,9 +99,9 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #'@param ro A scalar, or alternatively a multidimensional array with the same #' dimensions as wind, with the air density expressed in kg/m^3. By default it #' takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions matching the dimensions on parameter 'data'. By default it is -#' NULL, to select a period this parameter must be provided. +#'@param dates A multidimensional array of dates with named dimensions matching +#' the temporal dimensions on parameter 'data'. By default it is NULL, to +#' select aperiod this parameter must be provided. #'@param start An optional parameter to defined the initial date of the period #' to select from the data by providing a list of two elements: the initial #' date of the period and the initial month of the period. By default it is set @@ -101,7 +112,7 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #' the period and the final month of the period. By default it is set to NULL #' and the indicator is computed using all the data provided in \code{data}. #'@param time_dim A character string indicating the name of the dimension to -#' compute the indicator. By default, it is set to 'ftime'. More than one +#' compute the indicator. By default, it is set to 'time'. More than one #' dimension name matching the dimensions provided in the object #' \code{data$data} can be specified. #'@param ncores An integer indicating the number of cores to use in parallel @@ -111,20 +122,39 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #'Density expressed in W/m^2. #' #'@examples -#'wind <- rweibull(n = 100, shape = 2, scale = 6) -#'WPD <- WindPowerDensity(wind) +#'wind <- array(rweibull(n = 32100, shape = 2, scale = 6), +#' c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) +#'Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), +#' as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2001", format = "%d-%m-%Y"), +#' as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), +#' seq(as.Date("01-05-2002", format = "%d-%m-%Y"), +#' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +#'dim(Dates) <- c(sdate = 3, time = 214) +#'WPD <- WindPowerDensity(wind, dates = Dates, start = list(21, 4), +#' end = list(21, 6)) #' #'@export WindPowerDensity <- function(wind, ro = 1.225, dates = NULL, start = NULL, end = NULL, time_dim = 'time', ncores = NULL) { - if (!is.null(dates)) { - if (!is.null(start) && !is.null(end)) { + + if (!is.null(start) && !is.null(end)) { + if (is.null(dates)) { + warning("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + } else { if (!any(c(is.list(start), is.list(end)))) { stop("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") } - wind <- SelectPeriodOnData(wind, dates, start, end, - time_dim = time_dim, ncores = ncores) + if (!is.null(dim(dates))) { + wind <- SelectPeriodOnData(data = wind, dates = dates, start = start, + end = end, time_dim = time_dim, + ncores = ncores) + } else { + warning("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + } } } return(0.5 * ro * wind^3) diff --git a/R/zzz.R b/R/zzz.R index cf9163970f76c2da74b3d811c1fa0b71445beeab..da7c3a18b558c8fe2f58fa301ada5303167025a7 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -24,35 +24,6 @@ return(position) } -# Function to subset dimension indices of an array -.arraysubset <- function(x, dim, value, drop = FALSE) { - indices <- rep(list(bquote()), length(dim(x))) - if (is.character(dim)) { - dim <- which(names(dim(x)) %in% dim) - } - indices[dim] <- value - call <- as.call(c(list(as.name("["), quote(x)), indices, drop = drop)) - eval(call) -} - -# Function to insert a dimension in an array -.insertdim <- function(data, posdim, lendim, name = NULL) { - names(lendim) <- name - data <- array(data, dim = c(dim(data), lendim)) - ## Reorder dimension - if (posdim == 1) { - order <- c(length(dim(data)), 1:(length(dim(data)) - 1)) - data <- aperm(data, order) - } else if (posdim == length(dim(data))) { # last dim - - } else { # middle dim - order <- c(1:(posdim - 1), length(dim(data)), posdim:(length(dim(data)) - 1)) - data <- aperm(data, order) - } - return(data) -} - - #======================= # Read a powercurve file # Create the approximation function @@ -88,4 +59,50 @@ wind2CF <- function(wind, pc) { power <- wind2power(wind, pc) CF <- power / pc$attr$RatedPower return(CF) -} \ No newline at end of file +} + +.KnownLonNames <- function() { + known_lon_names <- c('lon', 'lons', 'longitude', 'x', 'i', 'nav_lon') +} + +.KnownLatNames <- function() { + known_lat_names <- c('lat', 'lats', 'latitude', 'y', 'j', 'nav_lat') +} + +.return2list <- function(data1, data2 = NULL) { + if (is.null(data1) & is.null(data2)) { + return(NULL) + } else if (is.null(data2)) { + return(list(data1)) + } else { + return(list(data1, data2)) + } +} + +# Function that creates a mask array from dates for the whole year +.datesmask <- function(dates, frequency = 'monthly') { + years <- format(dates, "%Y") + ini <- as.Date(paste(min(years), 01, 01, sep = '-')) + end <- as.Date(paste(max(years), 12, 31, sep = '-')) + daily <- as.Date(seq(ini, end, by = "day")) + if (frequency == 'monthly') { + days <- as.numeric(format(daily, "%d")) + monthly <- daily[which(days == 1)] + dates_mask <- array(0, dim = length(monthly)) + for (dd in 1:length(dates)) { + year <- format(dates[dd], "%Y") + month <- format(dates[dd], "%m") + ii <- which(monthly == as.Date(paste(year, month, 01, sep = '-'))) + dates_mask[ii] <- 1 + } + } else { + # daily + dates_mask <- array(0, dim = length(daily)) + for (dd in 1:length(dates)) { + ii <- which(daily == dates[dd]) + dates_mask[ii] <- 1 + } + } + + return(dates_mask) +} diff --git a/README.md b/README.md index 5521a516c737721659480633a0a5ef715affd14a..360ecbee9b29b493c8fd2e43e595515612747f72 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,18 @@ CSIndicators #### Sectoral Indicators for Climate Services Based on Sub-Seasonal to Decadal Climate Predictions -Set of generalised tools for the flexible computation of climate related indicators defined by the user. Each method represents a specific mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate service application (agriculture, food security, energy, water management…). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with [CSTools](https://earth.bsc.es/gitlab/external/cstools). +Set of generalised tools for the flexible computation of climate related indicators defined by the user. Each method represents a specific mathematical approach which is combined with the possibility to select an arbitrary time period to define the indicator. This enables a wide range of possibilities to tailor the most suitable indicator for each particular climate service application (agriculture, food security, energy, water management…). This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales, provided the dimensional structure of the input is maintained. Additionally, the outputs of the functions in this package are compatible with [CSTools](https://earth.bsc.es/gitlab/external/cstools). + +How to cite +----------- + +> Pérez-Zanón, N., Ho, A. Chou, C., Lledó, L., Marcos-Matamoros, R., Rifà, E. and González-Reviriego, N. (2023). CSIndicators: Get tailored climate indicators for applications in your sector. Climate Services. https://doi.org/10.1016/j.cliser.2023.100393 + +For details in the methodologies see: + +> Pérez-Zanón, N., Caron, L.-P., Terzago, S., Van Schaeybroeck, B., Lledó, L., Manubens, N., Roulin, E., Alvarez-Castro, M. C., Batté, L., Bretonnière, P.-A., Corti, S., Delgado-Torres, C., Domínguez, M., Fabiano, F., Giuntoli, I., von Hardenberg, J., Sánchez-García, E., Torralba, V., and Verfaillie, D.: Climate Services Toolbox (CSTools) v4.0: from climate forecasts to climate forecast information, Geosci. Model Dev., 15, 6115–6142, https://doi.org/10.5194/gmd-15-6115-2022, 2022. +Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and N. González-Reviriego (2023). Advanced seasonal predictions for vine management based on bioclimatic indicators tailored to the wine sector. Climate Services, 30, 100343, https://doi.org/10.1016/j.cliser.2023.100343. +Lledó, Ll., V. Torralba, A. Soret, J. Ramon and F.J. Doblas-Reyes (2019). Seasonal forecasts of wind power generation. Renewable Energy, 143, 91-100, https://doi.org/10.1016/j.renene.2019.04.135. Installation ------------ diff --git a/man/AbsToProbs.Rd b/man/AbsToProbs.Rd index 7717c91e629da1345eb25df96f08054620776380..a4e99bafe3ba032770ca0be5cb0b4df60bcdb697 100644 --- a/man/AbsToProbs.Rd +++ b/man/AbsToProbs.Rd @@ -9,7 +9,7 @@ AbsToProbs( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -36,7 +36,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -62,17 +62,17 @@ Distribution Function excluding the corresponding initialization. } \examples{ exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) + time = 9, lat = 2, lon = 2)) exp_probs <- AbsToProbs(exp) data <- array(rnorm(5 * 3 * 61 * 1), - c(member = 5, sdate = 3, ftime = 61, lon = 1)) + c(member = 5, sdate = 3, time = 61, lon = 1)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-06-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-06-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-06-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 61, sdate = 3) +dim(Dates) <- c(time = 61, sdate = 3) exp_probs <- AbsToProbs(data, dates = Dates, start = list(21, 4), end = list(21, 6)) diff --git a/man/AccumulationExceedingThreshold.Rd b/man/AccumulationExceedingThreshold.Rd index 172592c89c091e771f5a13f2084f594dc25b51e2..976c967f82e56354b5553c7197705d828e6473dd 100644 --- a/man/AccumulationExceedingThreshold.Rd +++ b/man/AccumulationExceedingThreshold.Rd @@ -12,7 +12,7 @@ AccumulationExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -39,9 +39,9 @@ c('>', '<='), c('>=', '<'),c('>=', '<=')).} between data and threshold (TRUE) or not (FALSE by default). It can only be TRUE if a unique threshold is used.} -\item{dates}{A vector of dates or a multidimensional array with of dates with -named dimensions matching the dimensions on parameter 'data'. By default it -is NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to define the initial date of the period to select from the data by providing a list of two elements: the initial @@ -55,7 +55,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) @@ -78,20 +78,14 @@ use a percentile as a scalar, the function \code{Threshold} or following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{GDD}{Summation of daily differences between daily average - temperatures and 10°C between April 1st and October 31st} + \item{'GDD', Summation of daily differences between daily average + temperatures and 10°C between April 1st and October 31st.} } } \examples{ # Assuming data is already (tasmax + tasmin)/2 - 10 data <- array(rnorm(5 * 3 * 214 * 2, mean = 25, sd = 3), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), - as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), - as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), - as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) + c(memb = 5, sdate = 3, time = 214, lon = 2)) GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), end = list(31, 10)) } diff --git a/man/CST_AbsToProbs.Rd b/man/CST_AbsToProbs.Rd index 055bf6b571ad1fc82e1787e4805b6fe1743c89b8..45a733d6b47efbe9ba2868fe64b38f2c2961ac5d 100644 --- a/man/CST_AbsToProbs.Rd +++ b/man/CST_AbsToProbs.Rd @@ -8,15 +8,15 @@ CST_AbsToProbs( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to define the initial date of the period to select from the data by providing a list of two elements: the initial @@ -30,7 +30,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -56,17 +56,17 @@ Distribution Function excluding the corresponding initialization. \examples{ exp <- NULL exp$data <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) + time = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' exp_probs <- CST_AbsToProbs(exp) exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) exp_probs <- CST_AbsToProbs(data = exp, start = list(21, 4), end = list(21, 6)) } diff --git a/man/CST_AccumulationExceedingThreshold.Rd b/man/CST_AccumulationExceedingThreshold.Rd index bc0eb83f4d4d1b168b956c63facbbb6ea5de4fc4..ceb9ad74b4bce72f675b055709b6c9651ad9ae7d 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -11,14 +11,14 @@ CST_AccumulationExceedingThreshold( diff = FALSE, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{If only one threshold is used, it can be an 's2dv_cube' object or a multidimensional array with named dimensions. It must be in the @@ -51,7 +51,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) @@ -63,7 +63,12 @@ computation.} \value{ An 's2dv_cube' object containing the aggregated values in the element \code{data} with dimensions of the input parameter 'data' except the dimension -where the indicator has been computed. +where the indicator has been computed. The 'Dates' array is updated to +the dates corresponding to the beginning of the aggregated time period. A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. } \description{ The accumulation (sum) of a variable in the days (or time steps) that the @@ -74,15 +79,25 @@ use a percentile as a scalar, the function \code{Threshold} or following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{GDD}{Summation of daily differences between daily average - temperatures and 10°C between April 1st and October 31st} + \item{'GDD', Summation of daily differences between daily average + temperatures and 10°C between April 1st and October 31st.} } } \examples{ exp <- NULL -exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, - ftime = 9, lat = 2, lon = 2)) +exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*100), + c(memb = 5, sdate = 3, time = 214, lon = 2)) class(exp) <- 's2dv_cube' -DOT <- CST_AccumulationExceedingThreshold(exp, threshold = 280) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) +exp$attrs$Dates <- Dates +AT <- CST_AccumulationExceedingThreshold(data = exp, threshold = 100, + start = list(21, 4), + end = list(21, 6)) } diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index 9f9a3b977ce032bb44b6eb7724574738992e5d65..b95ef79881cdb87a27bf5033c2877680d6a14e81 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -7,80 +7,107 @@ CST_MergeRefToExp( data1, data2, - start1, - end1, - start2, - end2, - time_dim = "ftime", - sdate_dim = "sdate", + start1 = NULL, + end1 = NULL, + start2 = NULL, + end2 = NULL, + time_dim = "time", + memb_dim = "member", ncores = NULL ) } \arguments{ -\item{data1}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data1}{An 's2dv_cube' object with the element 'data' being a +multidimensional array with named dimensions. All dimensions must be +equal to 'data2' dimensions except for the ones specified with 'memb_dim' +and 'time_dim'. If 'start1' and 'end1' are used to subset a period, the +Dates must be stored in element '$attrs$Dates' of the object. Dates must +have same time dimensions as element 'data'.} -\item{data2}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data2}{An 's2dv_cube' object with the element 'data' being a +multidimensional array of named dimensions matching the dimensions of +parameter 'data1'. All dimensions must be equal to 'data1' except for the +ones specified with 'memb_dim' and 'time_dim'. If 'start2' and 'end2' are +used to subset a period, the Dates must be stored in element '$attrs$Dates' +of the object. Dates must have same time dimensions as element 'data'.} \item{start1}{A list to define the initial date of the period to select from -data1 by providing a list of two elements: the initial date of the period +'data1' by providing a list of two elements: the initial date of the period and the initial month of the period.} \item{end1}{A list to define the final date of the period to select from -data1 by providing a list of two elements: the final day of the period and +'data1' by providing a list of two elements: the final day of the period and the final month of the period.} \item{start2}{A list to define the initial date of the period to select from -data2 by providing a list of two elements: the initial date of the period +'data2' by providing a list of two elements: the initial date of the period and the initial month of the period.} \item{end2}{A list to define the final date of the period to select from -data2 by providing a list of two elements: the final day of the period and +'data2' by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name -matching the dimensions provided in the object \code{data$data} can be -specified. This dimension is required to subset the data in a requested period.} +dimension that will be used to combine the two arrays. By default, it is set +to 'time'. Also, it will be used to subset the data in a requested +period.} -\item{sdate_dim}{A character string indicating the name of the dimension in -which the initialization dates are stored.} +\item{memb_dim}{A character string indicating the name of the member +dimension. If the data are not ensemble ones, set as NULL. The default +value is 'member'.} \item{ncores}{An integer indicating the number of cores to use in parallel computation.} } \value{ -A 's2dv_cube' object containing the indicator in the element - \code{data}. +An 's2dv_cube' object containing the indicator in the element +\code{data}. The element \code{data} will be a multidimensional array created +from the combination of 'data1' and 'data2'. The resulting array will contain +the following dimensions: the original dimensions of the input data, which are +common to both arrays and for the 'time_dim' dimension, the sum of the +corresponding dimension of 'data1' and 'data2'. If 'memb_dim' is not null, +regarding member dimension, two different situations can occur: (1) in the +case that one of the arrays does not have member dimension or is equal to 1 +and the other array has multiple member dimension, the result will contain the +repeated values of the array one up to the lenght of member dimension of array +two; (2) in the case that both arrays have member dimension and is greater +than 1, all combinations of member dimension will be returned. The other +elements of the 's2dv_cube' will be updated with the combined information of +both datasets. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from June 21st to September 21st). If the initialization forecast date is later than the one required for the indicator (e.g.: July 1st), the user may want to -merge past observations, or other references, to the forecast (or hindcast) -to compute the indicator. The function \code{MergeObs2Exp} takes care of this -steps. If the forecast simulation doesn't cover the required period because it -is initialized too early (e.g.: Initialization on November 1st the forecast -covers until the beginning of June next year), a climatology (or other -references) could be added at the end of the forecast lead time to cover the -desired period (e.g.: until the end of summer). +merge past observations, or other references, to the forecast (or hindcast) to +compute the indicator. If the forecast simulation doesn't cover the required +period because it is initialized too early (e.g.: Initialization on November +1st the forecast covers until the beginning of June next year), a climatology +(or other references) could be added at the end of the forecast lead time to +cover the desired period (e.g.: until the end of summer). +} +\details{ +This function is created to merge observations and forecasts, known as the +‘blending’ strategy (see references). The basis for this strategy is that the +predictions are progressively replaced with observational data as soon as they +become available (i.e., when entering the indicator definition period). This +key strategy aims to increase users’ confidence in the reformed predictions. } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) -dim(data_dates) <- c(ftime = 154, sdate = 2) +dim(data_dates) <- c(time = 154, sdate = 2) data <- NULL -data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member= 2)) +data$data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) data$attrs$Dates<- data_dates class(data) <- 's2dv_cube' ref_dates <- seq(as.Date("01-01-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day") -dim(ref_dates) <- c(ftime = 350, sdate = 2) +dim(ref_dates) <- c(time = 350, sdate = 2) ref <- NULL -ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) +ref$data <- array(1001:1700, c(time = 350, sdate = 2)) ref$attrs$Dates <- ref_dates class(ref) <- 's2dv_cube' new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, @@ -88,3 +115,10 @@ new_data <- CST_MergeRefToExp(data1 = ref, data2 = data, start2 = list(1, 7), end2 = list(21, 9)) } +\references{ +Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +N. González-Reviriego (2023). Advanced seasonal predictions for vine +management based on bioclimatic indicators tailored to the wine sector. +Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. +} diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index 39287052dc1e55d5bef9e24046e875bee38cdb73..c1b4a1ccd73d9938d4cebc11cf51a7205241a9e5 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -8,19 +8,22 @@ CST_PeriodAccumulation( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", + rollwidth = NULL, + sdate_dim = "sdate", + frequency = "monthly", na.rm = FALSE, ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial -date of the period and the initial month of the period. By default it is set -to NULL and the indicator is computed using all the data provided in +date of the period and the initial m onth of the period. By default it is +set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{end}{An optional parameter to defined the final date of the period to @@ -29,10 +32,26 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} +\item{rollwidth}{An optional parameter to indicate the number of time +steps the rolling sum is applied to. If it is positive, the rolling sum is +applied backwards 'time_dim', if it is negative, it will be forward it. When +this parameter is NULL, the sum is applied over all 'time_dim', in a +specified period. It is NULL by default.} + +\item{sdate_dim}{(Only needed when rollwidth is used). A character string +indicating the name of the start date dimension to compute the rolling +accumulation. By default, it is set to 'sdate'.} + +\item{frequency}{(Only needed when rollwidth is used). A character string +indicating the time frequency of the data to apply the rolling accumulation. +It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +continuous months will be accumulated; if it is 'daliy', values from +continuous days will be accumulated. It is set to 'monthly' by default.} + \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -40,38 +59,63 @@ not (FALSE).} computation.} } \value{ -A 's2dv_cube' object containing the indicator in the element -\code{data}. +An 's2dv_cube' object containing the accumulated data in the element +\code{data}. If parameter 'rollwidth' is not used, it will have the dimensions +of the input parameter 'data' except the dimension where the accumulation has +been computed (specified with 'time_dim'). If 'rollwidth' is used, it will be +of same dimensions as input data. The 'Dates' array is updated to the +dates corresponding to the beginning of the aggregated time period. A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. If 'rollwidth' is used, it will contain the same dimensions of +parameter 'data' and the other elements of the 's2dv_cube' will not be +modified. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a period. Providing precipitation data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{SprR}{Spring Total Precipitation: The total precipitation from - April 21th to June 21st} - \item\code{HarR}{Harvest Total Precipitation: The total precipitation from - August 21st to October 21st} + \item{'SprR', Spring Total Precipitation: The total precipitation from + April 21th to June 21st.} + \item{'HarR', Harvest Total Precipitation: The total precipitation from + August 21st to October 21st.} +} } +\details{ +There are two possible ways of performing the accumulation. The default one +is by accumulating a variable over a dimension specified with 'time_dim'. To +chose a specific time period, 'start' and 'end' must be used. The other method +is by using 'rollwidth' parameter. When this parameter is a positive integer, +the cumulative backward sum is applied to the time dimension. If it is +negative, the rolling sum is applied backwards. This function is build to +be compatible with other tools in that work with 's2dv_cube' object class. The +input data must be this object class. If you don't work with 's2dv_cube', see +PeriodAccumulation. } \examples{ exp <- NULL exp$data <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) class(exp) <- 's2dv_cube' -TP <- CST_PeriodAccumulation(exp) -exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), - as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), - as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), - seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), - as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6)) +TP <- CST_PeriodAccumulation(exp, time_dim = 'ftime') +exp$data <- array(rnorm(5 * 3 * 214 * 2), + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, ftime = 214) +exp$attrs$Dates <- Dates +SprR <- CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), + time_dim = 'ftime') dim(SprR$data) head(SprR$attrs$Dates) -HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10)) +HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10), + time_dim = 'ftime') dim(HarR$data) head(HarR$attrs$Dates) diff --git a/man/CST_PeriodMax.Rd b/man/CST_PeriodMax.Rd new file mode 100644 index 0000000000000000000000000000000000000000..3c760ba2a0cd2573b413d20069fcd4a4619bf7a1 --- /dev/null +++ b/man/CST_PeriodMax.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMax.R +\name{CST_PeriodMax} +\alias{CST_PeriodMax} +\title{Period Max on 's2dv_cube' objects} +\usage{ +CST_PeriodMax( + data, + start = NULL, + end = NULL, + time_dim = "time", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'time'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the max has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Max computes the maximum (max) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item{'BIO5', (Providing temperature data) Max Temperature of Warmest + Month. The maximum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO13', (Providing precipitation data) Precipitation of Wettest + Month. This index identifies the total precipitation + that prevails during the wettest month.} +} +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +res <- CST_PeriodMax(exp, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index b1004ad56896fe2aa943677debd1aeec1590888f..3f510418f91418fceac18676036f7e4e76d0d0a3 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -8,14 +8,14 @@ CST_PeriodMean( data, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -29,7 +29,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -41,27 +41,40 @@ computation.} } \value{ An 's2dv_cube' object containing the indicator in the element - \code{data}. +\code{data} with dimensions of the input parameter 'data' except the +dimension where the mean has been computed (specified with 'time_dim'). The +'Dates' array is updated to the dates corresponding to the beginning of the +aggregated time period. A new element called 'time_bounds' will be added into +the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ Period Mean computes the average (mean) of a given variable in a period. Providing temperature data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{GST}{Growing Season average Temperature: The average temperature - from April 1st to Octobe 31st} - \item\code{SprTX}{Spring Average Maximum Temperature: The average daily - maximum temperature from April 1st to May 31st} + \item{'GST', Growing Season average Temperature: The average temperature + from April 1st to Octobe 31st.} + \item{'SprTX', Spring Average Maximum Temperature: The average daily + maximum temperature from April 1st to May 31st.} } } \examples{ exp <- NULL -exp$data <- array(rnorm(45), dim = c(member = 7, ftime = 8)) +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +exp$attrs$Dates <- Dates class(exp) <- 's2dv_cube' -exp$attrs$Dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), - as.Date("01-08-1993","\%d-\%m-\%Y", tz = 'UTC'), "day"), - seq(as.Date("01-07-1994", "\%d-\%m-\%Y", tz = 'UTC'), - as.Date("01-08-1994","\%d-\%m-\%Y", tz = 'UTC'), "day")) -SA <- CST_PeriodMean(exp) + +SA <- CST_PeriodMean(exp, start = list(01, 12), end = list(01, 01)) } diff --git a/man/CST_PeriodMin.Rd b/man/CST_PeriodMin.Rd new file mode 100644 index 0000000000000000000000000000000000000000..97caa6e060a3a837060a65053bc4632a96b19040 --- /dev/null +++ b/man/CST_PeriodMin.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMin.R +\name{CST_PeriodMin} +\alias{CST_PeriodMin} +\title{Period Min on 's2dv_cube' objects} +\usage{ +CST_PeriodMin( + data, + start = NULL, + end = NULL, + time_dim = "time", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'time'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the min has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Min computes the average (min) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item{'BIO6', (Providing temperature data) Min Temperature of Coldest + Month. The minimum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO14', (Providing precipitation data) Precipitation of Driest + Month. This index identifies the total precipitation + that prevails during the driest month.} +} +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +res <- CST_PeriodMin(exp, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/CST_PeriodPET.Rd b/man/CST_PeriodPET.Rd new file mode 100644 index 0000000000000000000000000000000000000000..eb84f25ac7129ea296b12b904105667936ef11aa --- /dev/null +++ b/man/CST_PeriodPET.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodPET.R +\name{CST_PeriodPET} +\alias{CST_PeriodPET} +\title{Compute the Potential Evapotranspiration} +\usage{ +CST_PeriodPET( + data, + pet_method = "hargreaves", + time_dim = "syear", + leadtime_dim = "time", + lat_dim = "latitude", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A named list with the needed \code{s2dv_cube} objects containing +the seasonal forecast experiment in the 'data' element for each variable. +Specific variables are needed for each method used in computing the +Potential Evapotranspiration (see parameter 'pet_method'). The accepted +variable names are fixed in order to be recognized by the function. +The accepted name corresponding to the Minimum Temperature is 'tmin', +for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +for Precipitation is 'pr'. The accepted variable names for each method are: +For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +degrees; the units for precipitation ('pr') need to be in mm/month. +Currently the function works only with monthly data from different years.} + +\item{pet_method}{A character string indicating the method used to compute +the potential evapotranspiration. The accepted methods are: +'hargreaves' and 'hargreaves_modified', that require the data to have +variables tmin and tmax; and 'thornthwaite', that requires variable +'tmean'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{lat_dim}{A character string indicating the name of the latitudinal +dimension. By default it is set by 'latitude'.} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\description{ +Compute the Potential evapotranspiration (PET) that is the amount of +evaporation and transpiration that would occur if a sufficient water source +were available. This function calculate PET according to the Thornthwaite, +Hargreaves or Hargreaves-modified equations. +} +\details{ +This function is build to be compatible with other tools in +that work with 's2dv_cube' object class. The input data must be this object +class. If you don't work with 's2dv_cube', see PeriodPET. For more information +on the SPEI calculation, see functions CST_PeriodStandardization and +CST_PeriodAccumulation. +} +\examples{ +dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +end_year <- 2012 +dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), + paste0(2010:end_year, "-09-15"), + paste0(2010:end_year, "-10-16")), "UTC") +dim(dates_exp) <- c(syear = 3, time = 3) +lat <- c(40) +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) + +} diff --git a/man/CST_PeriodStandardization.Rd b/man/CST_PeriodStandardization.Rd new file mode 100644 index 0000000000000000000000000000000000000000..fe0dd3b9f59e082ae322e884b94415ea4246c8af --- /dev/null +++ b/man/CST_PeriodStandardization.Rd @@ -0,0 +1,125 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodStandardization.R +\name{CST_PeriodStandardization} +\alias{CST_PeriodStandardization} +\title{Compute the Standardization of Precipitation-Evapotranspiration Index} +\usage{ +CST_PeriodStandardization( + data, + data_cor = NULL, + time_dim = "syear", + leadtime_dim = "time", + memb_dim = "ensemble", + ref_period = NULL, + handle_infinity = FALSE, + method = "parametric", + distribution = "log-Logistic", + params = NULL, + return_params = FALSE, + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' that element 'data' stores a multidimensional +array containing the data to be standardized.} + +\item{data_cor}{An 's2dv_cube' that element 'data' stores a multidimensional +array containing the data in which the standardization should be applied +using the fitting parameters from 'data'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{memb_dim}{A character string indicating the name of the dimension in +which the ensemble members are stored. When set it to NULL, threshold is +computed for individual members.} + +\item{ref_period}{A list with two numeric values with the starting and end +points of the reference period used for computing the index. The default +value is NULL indicating that the first and end values in data will be +used as starting and end points.} + +\item{handle_infinity}{A logical value wether to return infinite values (TRUE) +or not (FALSE). When it is TRUE, the positive infinite values (negative +infinite) are substituted by the maximum (minimum) values of each +computation step, a subset of the array of dimensions time_dim, leadtime_dim +and memb_dim.} + +\item{method}{A character string indicating the standardization method used. +If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +default.} + +\item{distribution}{A character string indicating the name of the distribution +function to be used for computing the SPEI. The accepted names are: +'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +'Gamma' method only works when only precipitation is provided and other + variables are 0 because it is positive defined (SPI indicator).} + +\item{params}{An optional parameter that needs to be a multidimensional array +with named dimensions. This option overrides computation of fitting +parameters. It needs to be of same time dimensions (specified in 'time_dim' +and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +of the coefficients needed for the used distribution (for 'Gamma' coef +dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +will only be used if 'data_cor' is not provided.} + +\item{return_params}{A logical value indicating wether to return parameters +array (TRUE) or not (FALSE). It is FALSE by default.} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default. If it is FALSE and there are NA values, +standardization cannot be carried out for those coordinates and therefore, +the result will be filled with NA for the specific coordinates. If it is +TRUE, if the data from other dimensions except time_dim and leadtime_dim is +not reaching 4 values, it is not enough values to estimate the parameters +and the result will include NA.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\value{ +An object of class \code{s2dv_cube} containing the standardized data. +If 'data_cor' is provided the array stored in element data will be of the same +dimensions as 'data_cor'. If 'data_cor' is not provided, the array stored in +element data will be of the same dimensions as 'data'. The parameters of the +standardization will only be returned if 'return_params' is TRUE, in this +case, the output will be a list of two objects one for the standardized data +and one for the parameters. +} +\description{ +The Standardization of the data is the last step of computing the SPEI +(Standarized Precipitation-Evapotranspiration Index). With this function the +data is fit to a probability distribution to transform the original values to +standardized units that are comparable in space and time and at different SPEI +time scales. +} +\details{ +Next, some specifications for the calculation of the standardization will be +discussed. If there are NAs in the data and they are not removed with the +parameter 'na.rm', the standardization cannot be carried out for those +coordinates and therefore, the result will be filled with NA for the +specific coordinates. When NAs are not removed, if the length of the data for +a computational step is smaller than 4, there will not be enough data for +standarize and the result will be also filled with NAs for that coordinates. +About the distribution used to fit the data, there are only two possibilities: +'log-logistic' and 'Gamma'. The 'Gamma' method only works when only +precipitation is provided and other variables are 0 because it is positive +defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +standardization is computed with cross validation. This function is build to +be compatible with other tools in that work with 's2dv_cube' object +class. The input data must be this object class. If you don't work with +'s2dv_cube', see PeriodStandardization. For more information on the SPEI +indicator calculation, see CST_PeriodPET and CST_PeriodAccumulation. +} +\examples{ +dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) +data <- NULL +data$data <- array(rnorm(600, -204.1, 78.1), dim = dims) +class(data) <- 's2dv_cube' +SPEI <- CST_PeriodStandardization(data = data) +} diff --git a/man/CST_PeriodVariance.Rd b/man/CST_PeriodVariance.Rd new file mode 100644 index 0000000000000000000000000000000000000000..4d789ddde3f07486b2a7bdde7786a3f9ee67dad3 --- /dev/null +++ b/man/CST_PeriodVariance.Rd @@ -0,0 +1,84 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodVariance.R +\name{CST_PeriodVariance} +\alias{CST_PeriodVariance} +\title{Period Variance on 's2dv_cube' objects} +\usage{ +CST_PeriodVariance( + data, + start = NULL, + end = NULL, + time_dim = "time", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'time'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +An 's2dv_cube' object containing the indicator in the element +\code{data} with dimensions of the input parameter 'data' except the +dimension where the var has been computed (specified with 'time_dim'). A new +element called 'time_bounds' will be added into the 'attrs' element in the +'s2dv_cube' object. It consists of a list containing two elements, the start +and end dates of the aggregated period with the same dimensions of 'Dates' +element. +} +\description{ +Period Variance computes the average (var) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item{'BIO4', (Providing temperature data) Temperature Seasonality + (Standard Deviation). The amount of temperature variation + over a given year (or averaged years) based on the standard + deviation (variation) of monthly temperature averages.} + \item{'BIO15', (Providing precipitation data) Precipitation Seasonality + (CV). This is a measure of the variation in monthly precipitation + totals over the course of the year. This index is the ratio of the + standard deviation of the monthly total precipitation to the mean + monthly total precipitation (also known as the coefficient of + variation) and is expressed as a percentage.} +} +} +\examples{ +exp <- NULL +exp$data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +exp$attrs$Dates <- Dates +class(exp) <- 's2dv_cube' + +res <- CST_PeriodVariance(exp, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/CST_QThreshold.Rd b/man/CST_QThreshold.Rd index eda0fd1ced67dd2d87d4b6924f343e4e27304ea1..a07d130ef89a2fe4e3a8491072dddef497a91027 100644 --- a/man/CST_QThreshold.Rd +++ b/man/CST_QThreshold.Rd @@ -9,15 +9,15 @@ CST_QThreshold( threshold, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{An 's2dv_cube' object as output of a 'CST_' function in the same units as parameter 'data' and with the common dimensions of the element @@ -35,7 +35,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -80,17 +80,21 @@ and memb_dim parameters: \examples{ threshold <- 26 exp <- NULL -exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, ftime = 2)) +exp$data <- array(abs(rnorm(112)*26), dim = c(member = 7, sdate = 8, time = 2)) class(exp) <- 's2dv_cube' exp_probs <- CST_QThreshold(exp, threshold) -exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + +exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -exp_probs <- CST_QThreshold(exp, threshold) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) +class(exp) <- 's2dv_cube' +exp_probs <- CST_QThreshold(exp, threshold, start = list(21, 4), + end = list(21, 6)) } diff --git a/man/CST_SelectPeriodOnData.Rd b/man/CST_SelectPeriodOnData.Rd index 22b2a9c2dee5baa668962d8ade5a6d0519810581..5e4eff434bec51f97c5334e0c5120b05330a15f0 100644 --- a/man/CST_SelectPeriodOnData.Rd +++ b/man/CST_SelectPeriodOnData.Rd @@ -4,11 +4,11 @@ \alias{CST_SelectPeriodOnData} \title{Select a period on Data on 's2dv_cube' objects} \usage{ -CST_SelectPeriodOnData(data, start, end, time_dim = "ftime", ncores = NULL) +CST_SelectPeriodOnData(data, start, end, time_dim = "time", ncores = NULL) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{start}{A parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial date of the @@ -19,7 +19,7 @@ the data by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. More than one +compute select the dates. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -36,14 +36,14 @@ Auxiliary function to subset data for a specific period. \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) class(exp) <- 's2dv_cube' Period <- CST_SelectPeriodOnData(exp, start = list(21, 6), end = list(21, 9)) } diff --git a/man/CST_Threshold.Rd b/man/CST_Threshold.Rd index ffe06000d67a6c1371749a872a3d48d1d0dc4be8..07571b54ca01270fe3c57a4047fb711c6d70a29f 100644 --- a/man/CST_Threshold.Rd +++ b/man/CST_Threshold.Rd @@ -9,7 +9,7 @@ CST_Threshold( threshold, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", memb_dim = "member", sdate_dim = "sdate", na.rm = FALSE, @@ -17,11 +17,11 @@ CST_Threshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{A single scalar or vector indicating the relative -threshold(s).} +threshold(s). It must contain values between 0 and 1.} \item{start}{An optional parameter to defined the initial date of the period to selectfrom the data by providing a list of two elements: the initial date @@ -35,7 +35,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -67,13 +67,14 @@ given a dataset. threshold <- 0.9 exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' exp_probs <- CST_Threshold(exp, threshold, start = list(21, 4), end = list(21, 6)) diff --git a/man/CST_TotalSpellTimeExceedingThreshold.Rd b/man/CST_TotalSpellTimeExceedingThreshold.Rd index e2f7d26c15bd92c2ef82bcf21d250ce8aac514df..89d2fb2d4ab090c253e9c004c6871e71dcc63d35 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -11,13 +11,13 @@ CST_TotalSpellTimeExceedingThreshold( op = ">", start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{If only one threshold is used, it can be an 's2dv_cube' object or a multidimensional array with named dimensions. It must be in the @@ -48,7 +48,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -56,7 +56,13 @@ computation.} } \value{ An 's2dv_cube' object containing the number of days that are part of a -spell within a threshold in element \code{data}. +spell within a threshold in element \code{data} with dimensions of the input +parameter 'data' except the dimension where the indicator has been computed. +The 'Dates' array is updated to the dates corresponding to the beginning of +the aggregated time period. A new element called 'time_bounds' will be added +into the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ The number of days (when daily data is provided) that are part of a spell @@ -65,9 +71,9 @@ exceed) a threshold are calculated with \code{TotalSpellTimeExceedingThreshold}. This function allows to compute indicators widely used in Climate Services, such as: \itemize{ -\code{WSDI}{Warm Spell Duration Index that count the total number of days - with at least 6 consecutive days when the daily temperature - maximum exceeds its 90th percentile.} + \item{'WSDI', Warm Spell Duration Index that count the total number of days + with at least 6 consecutive days when the daily temperature + maximum exceeds its 90th percentile.} } This function requires the data and the threshold to be in the same units. The 90th percentile can be translate into absolute values given a reference dataset @@ -77,15 +83,18 @@ by using function \code{AbsToProbs}. See section @examples. \examples{ exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, - c(member = 5, sdate = 3, ftime = 214, lon = 2)) + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' -TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3) +TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3, + start = list(21, 4), + end = list(21, 6)) } \seealso{ diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index b09ae53bb10e5b46fdd792a7d523bd70300c4462..e0b8ed4521c2cb84bc8b5b078136bb2609c55fdc 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -10,14 +10,14 @@ CST_TotalTimeExceedingThreshold( op = ">", start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in -package CSTools.} +\item{data}{An 's2dv_cube' object as provided function \code{CST_Start} or +\code{CST_Load} in package CSTools.} \item{threshold}{If only one threshold is used, it can be an 's2dv_cube' object or a multidimensional array with named dimensions. It must be in the @@ -46,7 +46,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or @@ -58,7 +58,13 @@ computation.} \value{ An 's2dv_cube' object containing in element \code{data} the total number of the corresponding units of the data frequency that a variable is -exceeding a threshold during a period. +exceeding a threshold during a period with dimensions of the input parameter +'data' except the dimension where the indicator has been computed. The +'Dates' array is updated to the dates corresponding to the beginning of the +aggregated time period. A new element called 'time_bounds' will be added into +the 'attrs' element in the 's2dv_cube' object. It consists of a list +containing two elements, the start and end dates of the aggregated period with +the same dimensions of 'Dates' element. } \description{ The Total Time of a variable exceeding (or not) a Threshold. It returns the @@ -70,28 +76,30 @@ variable units, i.e. to use a percentile as a scalar, the function Providing maximum temperature daily data, the following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{SU35}{Total count of days when daily maximum temperatures exceed - 35°C in the seven months from the start month given (e.g. - from April to October for start month of April).} - \item\code{SU36}{Total count of days when daily maximum temperatures exceed - 36 between June 21st and September 21st} - \item\code{SU40}{Total count of days when daily maximum temperatures exceed - 40 between June 21st and September 21st} - \item\code{Spr32}{Total count of days when daily maximum temperatures exceed - 32 between April 21st and June 21st} + \item{'SU35', Total count of days when daily maximum temperatures exceed + 35°C in the seven months from the start month given (e.g. from April + to October for start month of April).} + \item{'SU36', Total count of days when daily maximum temperatures exceed + 36 between June 21st and September 21st.} + \item{'SU40', Total count of days when daily maximum temperatures exceed + 40 between June 21st and September 21st.} + \item{'Spr32', Total count of days when daily maximum temperatures exceed + 32 between April 21st and June 21st.} } } \examples{ exp <- NULL -exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*280), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) +exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, + c(member = 5, sdate = 3, time = 214, lon = 2)) exp$attrs$Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(sdate = 3, time = 214) class(exp) <- 's2dv_cube' -DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 280) +DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 23, start = list(21, 4), + end = list(21, 6)) } diff --git a/man/CST_WindCapacityFactor.Rd b/man/CST_WindCapacityFactor.Rd index 638f5b858ff97d9dcc7302bfda05c49a5b921959..cea2b067262b4730fc8b81f95379e5ce493a9cc8 100644 --- a/man/CST_WindCapacityFactor.Rd +++ b/man/CST_WindCapacityFactor.Rd @@ -9,7 +9,7 @@ CST_WindCapacityFactor( IEC_class = c("I", "I/II", "II", "II/III", "III"), start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -35,7 +35,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -60,14 +60,23 @@ below). \examples{ wind <- NULL wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), - c(member = 10, lat = 2, lon = 5)) + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) wind$coords <- list(lat = c(40, 41), lon = 1:5) variable <- list(varName = 'sfcWind', metadata = list(sfcWind = list(level = 'Surface'))) wind$attrs <- list(Variable = variable, Datasets = 'synthetic', when = Sys.time(), Dates = '1990-01-01 00:00:00') +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) +wind$attrs$Dates <- Dates class(wind) <- 's2dv_cube' -WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") +WCF <- CST_WindCapacityFactor(wind, IEC_class = "III", + start = list(21, 4), end = list(21, 6)) } \references{ diff --git a/man/CST_WindPowerDensity.Rd b/man/CST_WindPowerDensity.Rd index c33bd8d99a3cb0f0bb37e1872e962f1878ab7674..ec82d8a0ef0e5d8b696960fc6c632aa46d484e92 100644 --- a/man/CST_WindPowerDensity.Rd +++ b/man/CST_WindPowerDensity.Rd @@ -9,13 +9,13 @@ CST_WindPowerDensity( ro = 1.225, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } \arguments{ -\item{wind}{An s2dv_cube object with instantaneous wind speeds expressed in m/s -obtained from CST_Load or s2dv_cube functions from CSTools pacakge.} +\item{wind}{An 's2dv_cube' object with instantaneous wind speeds expressed in +m/s obtained from CST_Start or s2dv_cube functions from CSTools pacakge.} \item{ro}{A scalar, or alternatively a multidimensional array with the same dimensions as wind, with the air density expressed in kg/m^3. By default it @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -53,14 +53,23 @@ it will give inaccurate results if used with period means. \examples{ wind <- NULL wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), - c(member = 10, lat = 2, lon = 5)) + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) wind$coords <- list(lat = c(40, 41), lon = 1:5) variable <- list(varName = 'sfcWind', metadata = list(sfcWind = list(level = 'Surface'))) wind$attrs <- list(Variable = variable, Datasets = 'synthetic', when = Sys.time(), Dates = '1990-01-01 00:00:00') +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) +wind$attrs$Dates <- Dates class(wind) <- 's2dv_cube' -WCF <- CST_WindPowerDensity(wind) +WPD <- CST_WindPowerDensity(wind, start = list(21, 4), + end = list(21, 6)) } \author{ diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index e6b40c8c57fdff75e2e16ed51aa3c1d6c7d38d76..e524ead2aec6c58ae859f37e329133b3ba199ecc 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -6,67 +6,97 @@ \usage{ MergeRefToExp( data1, - dates1, - start1, - end1, data2, - dates2, - start2, - end2, - time_dim = "ftime", - sdate_dim = "sdate", + dates1 = NULL, + dates2 = NULL, + start1 = NULL, + end1 = NULL, + start2 = NULL, + end2 = NULL, + time_dim = "time", + memb_dim = "member", ncores = NULL ) } \arguments{ -\item{data1}{A multidimensional array with named dimensions.} +\item{data1}{A multidimensional array with named dimensions. All dimensions +must be equal to 'data2' dimensions except for the ones specified with +'memb_dim' and 'time_dim'.} -\item{dates1}{A vector of dates or a multidimensional array of dates with -named dimensions matching the dimensions on parameter 'data1'.} +\item{data2}{A multidimensional array of named dimensions matching the +dimensions of parameter 'data1'. All dimensions must be equal to 'data1' +except for the ones specified with 'memb_dim' and 'time_dim'.} -\item{start1}{A list to define the initial date of the period to select from -data1 by providing a list of two elements: the initial date of the period -and the initial month of the period.} +\item{dates1}{A multidimensional array of dates with named dimensions matching +the temporal dimensions of parameter 'data1'. The common dimensions must be +equal to 'data1' dimensions.} -\item{end1}{A list to define the final date of the period to select from -data1 by providing a list of two elements: the final day of the period and -the final month of the period.} +\item{dates2}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data2'. The common dimensions must be +equal to 'data2' dimensions.} -\item{data2}{A multidimensional array with named dimensions.} +\item{start1}{A list to define the initial date of the period to select from +'data1' by providing a list of two elements: the initial date of the period +and the initial month of the period. The initial date of the period must be +included in the 'dates1' array.} -\item{dates2}{A vector of dates or a multidimensional array of dates with -named dimensions matching the dimensions on parameter 'data2'.} +\item{end1}{A list to define the final date of the period to select from +'data1' by providing a list of two elements: the final day of the period and +the final month of the period. The final date of the period must be +included in the 'dates1' array.} \item{start2}{A list to define the initial date of the period to select from -data2 by providing a list of two elements: the initial date of the period -and the initial month of the period.} +'data2' by providing a list of two elements: the initial date of the period +and the initial month of the period. The initial date of the period must be +included in the 'dates2' array.} \item{end2}{A list to define the final date of the period to select from -data2 by providing a list of two elements: the final day of the period and -the final month of the period.} +'data2' by providing a list of two elements: the final day of the period and +the final month of the period. The final date of the period must be +included in the 'dates2' array.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name -matching the dimensions provided in the object \code{data$data} can be -specified. This dimension is required to subset the data in a requested +dimension that will be used to combine the two arrays. By default, it is set +to 'time'. Also, it will be used to subset the data in a requested period.} -\item{sdate_dim}{A character string indicating the name of the dimension in -which the initialization dates are stored.} +\item{memb_dim}{A character string indicating the name of the member +dimension. If the 'data1' and 'data2' have no member dimension, set it as +NULL. It is set as 'member' by default.} \item{ncores}{An integer indicating the number of cores to use in parallel computation.} } \value{ -A multidimensional array with named dimensions. +A multidimensional array created from the combination of 'data1' and +'data2'. The resulting array will contain the following dimensions: the +original dimensions of the input data, which are common to both arrays and for +the 'time_dim' dimension, the sum of the corresponding dimension of 'data1' +and 'data2'. If 'memb_dim' is not null, regarding member dimension, two +different situations can occur: (1) in the case that one of the arrays does +not have member dimension or is equal to 1 and the other array has multiple +member dimension, the result will contain the repeated values of the array one +up to the lenght of member dimension of array two; (2) in the case that both +arrays have member dimension and is greater than 1, all combinations of member +dimension will be returned. } \description{ Some indicators are defined for specific temporal periods (e.g.: summer from June 21st to September 21st). If the initialization forecast date is later than the one required for the indicator (e.g.: July 1st), the user may want to -merge past observations, or other reference, to the forecast (or hindcast) to -compute the indicator. The function \code{MergeObs2Exp} takes care of this -steps. +merge past observations, or other references, to the forecast (or hindcast) to +compute the indicator. If the forecast simulation doesn't cover the required +period because it is initialized too early (e.g.: Initialization on November +1st the forecast covers until the beginning of June next year), a climatology +(or other references) could be added at the end of the forecast lead time to +cover the desired period (e.g.: until the end of summer). +} +\details{ +This function is created to merge observations and forecasts, known as the +‘blending’ strategy (see references). The basis for this strategy is that the +predictions are progressively replaced with observational data as soon as they +become available (i.e., when entering the indicator definition period). This +key strategy aims to increase users’ confidence in the reformed predictions. } \examples{ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), @@ -78,10 +108,17 @@ ref_dates <- seq(as.Date("01-01-1993", "\%d-\%m-\%Y", tz = 'UTC'), as.Date("01-12-1994","\%d-\%m-\%Y", tz = 'UTC'), "day") dim(ref_dates) <- c(time = 350, sdate = 2) ref <- array(1001:1700, c(time = 350, sdate = 2)) -data <- array(1:(2*154*2), c(time = 154, sdate = 2, member= 2)) +data <- array(1:(2*154*2), c(time = 154, sdate = 2, member = 2)) new_data <- MergeRefToExp(data1 = ref, dates1 = ref_dates, start1 = list(21, 6), end1 = list(30, 6), data2 = data, dates2 = data_dates, start2 = list(1, 7), end = list(21, 9), time_dim = 'time') } +\references{ +Chou, C., R. Marcos-Matamoros, L. Palma Garcia, N. Pérez-Zanón, +M. Teixeira, S. Silva, N. Fontes, A. Graça, A. Dell'Aquila, S. Calmanti and +N. González-Reviriego (2023). Advanced seasonal predictions for vine +management based on bioclimatic indicators tailored to the wine sector. +Climate Services, 30, 100343, \doi{10.1016/j.cliser.2023.100343}. +} diff --git a/man/PeriodAccumulation.Rd b/man/PeriodAccumulation.Rd index 99033211af06dc55c429d728d69c2fbee910c756..71b7d73ae391bbd8c09213e74845125dc6c3d951 100644 --- a/man/PeriodAccumulation.Rd +++ b/man/PeriodAccumulation.Rd @@ -10,6 +10,9 @@ PeriodAccumulation( start = NULL, end = NULL, time_dim = "time", + rollwidth = NULL, + sdate_dim = "sdate", + frequency = "monthly", na.rm = FALSE, ncores = NULL ) @@ -17,9 +20,9 @@ PeriodAccumulation( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -33,9 +36,23 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'time'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} +compute the indicator. By default, it is set to 'time'.} + +\item{rollwidth}{An optional parameter to indicate the number of time +steps the rolling sum is applied to. If it is positive, the rolling sum is +applied backwards 'time_dim', if it is negative, it will be forward it. When +this parameter is NULL, the sum is applied over all 'time_dim', in a +specified period. It is NULL by default.} + +\item{sdate_dim}{(Only needed when rollwidth is used). A character string +indicating the name of the start date dimension to compute the rolling +accumulation. By default, it is set to 'sdate'.} + +\item{frequency}{(Only needed when rollwidth is used). A character string +indicating the time frequency of the data to apply the rolling accumulation. +It can be 'daily' or 'monthly'. If it is set to 'monthly', values from +continuous months will be accumulated; if it is 'daliy', values from +continuous days will be accumulated. It is set to 'monthly' by default.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -45,33 +62,46 @@ computation.} } \value{ A multidimensional array with named dimensions containing the -indicator in the element \code{data}. +accumulated data in the element \code{data}. If parameter 'rollwidth' is +not used, it will have the dimensions of the input 'data' except the dimension +where the accumulation has been computed (specified with 'time_dim'). If +'rollwidth' is used, it will be of same dimensions as input data. } \description{ Period Accumulation computes the sum (accumulation) of a given variable in a period. Providing precipitation data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{SprR}{Spring Total Precipitation: The total precipitation from - April 21th to June 21st} - \item\code{HarR}{Harvest Total Precipitation: The total precipitation from - August 21st to October 21st} + \item{'SprR', Spring Total Precipitation: The total precipitation from + April 21th to June 21st.} + \item{'HarR', Harvest Total Precipitation: The total precipitation from + August 21st to October 21st.} +} } +\details{ +There are two possible ways of performing the accumulation. The default one +is by accumulating a variable over a dimension specified with 'time_dim'. To +chose a specific time period, 'start' and 'end' must be used. The other method +is by using 'rollwidth' parameter. When this parameter is a positive integer, +the cumulative backward sum is applied to the time dimension. If it is +negative, the rolling sum is applied backwards. } \examples{ exp <- array(rnorm(216)*200, dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) TP <- PeriodAccumulation(exp, time_dim = 'ftime') data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, time = 214, lon = 2)) -# ftime tested + c(memb = 5, sdate = 3, ftime = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), end = list(21, 6)) -HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), end = list(21, 10)) +dim(Dates) <- c(sdate = 3, ftime = 214) +SprR <- PeriodAccumulation(data, dates = Dates, start = list(21, 4), + end = list(21, 6), time_dim = 'ftime') +HarR <- PeriodAccumulation(data, dates = Dates, start = list(21, 8), + end = list(21, 10), time_dim = 'ftime') } diff --git a/man/PeriodMax.Rd b/man/PeriodMax.Rd new file mode 100644 index 0000000000000000000000000000000000000000..762b3c902dba912ac9b25d46010da7144b06b515 --- /dev/null +++ b/man/PeriodMax.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMax.R +\name{PeriodMax} +\alias{PeriodMax} +\title{Period max on multidimensional array objects} +\usage{ +PeriodMax( + data, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "time", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'time'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period max computes the average (max) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item{'BIO5', (Providing temperature data) Max Temperature of Warmest + Month. The maximum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO13', (Providing precipitation data) Precipitation of Wettest + Month. This index identifies the total precipitation + that prevails during the wettest month.} +} +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +res <- PeriodMax(data, dates = Dates, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/PeriodMean.Rd b/man/PeriodMean.Rd index fffb332299a35a3a67e7fe274059628d592e7d5a..b639d0936b38c19501344037f8c2fdb8bdf86735 100644 --- a/man/PeriodMean.Rd +++ b/man/PeriodMean.Rd @@ -17,9 +17,9 @@ PeriodMean( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -33,7 +33,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -52,14 +52,23 @@ Period Mean computes the average (mean) of a given variable in a period. Providing temperature data, two agriculture indices can be obtained by using this function: \itemize{ - \item\code{GST}{Growing Season average Temperature: The average - temperature from April 1st to Octobe 31st} - \item\code{SprTX}{Spring Average Maximum Temperature: The average daily - maximum temperature from April 1st to May 31st} + \item{'GST', Growing Season average Temperature: The average temperature + from April 1st to Octobe 31st.} + \item{'SprTX', Spring Average Maximum Temperature: The average daily + maximum temperature from April 1st to May 31st.} } } \examples{ -exp <- array(rnorm(56), dim = c(member = 7, ftime = 8)) -SA <- PeriodMean(exp, time_dim = 'ftime') +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +SA <- PeriodMean(data, dates = Dates, start = list(01, 12), end = list(01, 01)) } diff --git a/man/PeriodMin.Rd b/man/PeriodMin.Rd new file mode 100644 index 0000000000000000000000000000000000000000..597421c4ccb4104f1851fd0430168ff2f21da2b7 --- /dev/null +++ b/man/PeriodMin.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodMin.R +\name{PeriodMin} +\alias{PeriodMin} +\title{Period Min on multidimensional array objects} +\usage{ +PeriodMin( + data, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "time", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'time'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period Min computes the average (min) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item{'BIO6', (Providing temperature data) Min Temperature of Coldest + Month. The minimum monthly temperature occurrence over a + given year (time-series) or averaged span of years (normal).} + \item{'BIO14', (Providing precipitation data) Precipitation of Driest + Month. This index identifies the total precipitation + that prevails during the driest month.} +} +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +res <- PeriodMin(data, dates = Dates, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/PeriodPET.Rd b/man/PeriodPET.Rd new file mode 100644 index 0000000000000000000000000000000000000000..d8c77472fd021543b317efc2e02fd2948a55a3ed --- /dev/null +++ b/man/PeriodPET.Rd @@ -0,0 +1,84 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodPET.R +\name{PeriodPET} +\alias{PeriodPET} +\title{Compute the Potential Evapotranspiration} +\usage{ +PeriodPET( + data, + dates, + lat, + pet_method = "hargreaves", + time_dim = "syear", + leadtime_dim = "time", + lat_dim = "latitude", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A named list of multidimensional arrays containing +the seasonal forecast experiment data for each variable. +Specific variables are needed for each method used in computing the +Potential Evapotranspiration (see parameter 'pet_method'). The accepted +variable names are fixed in order to be recognized by the function. +The accepted name corresponding to the Minimum Temperature is 'tmin', +for Maximum Temperature is 'tmax', for Mean Temperature is 'tmean' and +for Precipitation is 'pr'. The accepted variable names for each method are: +For 'hargreaves': 'tmin' and 'tmax'; for 'hargreaves_modified' are 'tmin', +'tmax' and 'pr'; for method 'thornthwaite' 'tmean' is required. The units +for temperature variables ('tmin', 'tmax' and 'tmean') need to be in Celcius +degrees; the units for precipitation ('pr') need to be in mm/month. +Currently the function works only with monthly data from different years.} + +\item{dates}{An array of temporal dimensions containing the Dates of +'data'. It must be of class 'Date' or 'POSIXct'.} + +\item{lat}{A numeric vector containing the latitude values of 'data'.} + +\item{pet_method}{A character string indicating the method used to compute +the potential evapotranspiration. The accepted methods are: +'hargreaves' and 'hargreaves_modified', that require the data to have +variables tmin and tmax; and 'thornthwaite', that requires variable +'tmean'.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{lat_dim}{A character string indicating the name of the latitudinal +dimension. By default it is set by 'latitude'.} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\description{ +Compute the Potential Evapotranspiration (PET) that is the amount of +evaporation and transpiration that would occur if a sufficient water source +were available. This function calculate PET according to the Thornthwaite, +Hargreaves or Hargreaves-modified equations. +} +\details{ +For more information on the SPEI calculation, see functions +PeriodStandardization and PeriodAccumulation. +} +\examples{ +dims <- c(time = 3, syear = 3, ensemble = 1, latitude = 1) +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) +end_year <- 2012 +dates_exp <- as.POSIXct(c(paste0(2010:end_year, "-08-16"), + paste0(2010:end_year, "-09-15"), + paste0(2010:end_year, "-10-16")), "UTC") +dim(dates_exp) <- c(syear = 3, time = 3) +lat <- c(40) +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) +res <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) + +} diff --git a/man/PeriodStandardization.Rd b/man/PeriodStandardization.Rd new file mode 100644 index 0000000000000000000000000000000000000000..94bbee12044d81075d726b42d7f7757c465c3574 --- /dev/null +++ b/man/PeriodStandardization.Rd @@ -0,0 +1,125 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodStandardization.R +\name{PeriodStandardization} +\alias{PeriodStandardization} +\title{Compute the Standardization of Precipitation-Evapotranspiration Index} +\usage{ +PeriodStandardization( + data, + data_cor = NULL, + dates = NULL, + time_dim = "syear", + leadtime_dim = "time", + memb_dim = "ensemble", + ref_period = NULL, + handle_infinity = FALSE, + method = "parametric", + distribution = "log-Logistic", + params = NULL, + return_params = FALSE, + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array containing the data to be standardized.} + +\item{data_cor}{A multidimensional array containing the data in which the +standardization should be applied using the fitting parameters from 'data'.} + +\item{dates}{An array containing the dates of the data with the same time +dimensions as the data. It is optional and only necessary for using the +parameter 'ref_period' to select a reference period directly from dates.} + +\item{time_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'syear'.} + +\item{leadtime_dim}{A character string indicating the name of the temporal +dimension. By default, it is set to 'time'.} + +\item{memb_dim}{A character string indicating the name of the dimension in +which the ensemble members are stored. When set it to NULL, threshold is +computed for individual members.} + +\item{ref_period}{A list with two numeric values with the starting and end +points of the reference period used for computing the index. The default +value is NULL indicating that the first and end values in data will be +used as starting and end points.} + +\item{handle_infinity}{A logical value wether to return infinite values (TRUE) +or not (FALSE). When it is TRUE, the positive infinite values (negative +infinite) are substituted by the maximum (minimum) values of each +computation step, a subset of the array of dimensions time_dim, leadtime_dim +and memb_dim.} + +\item{method}{A character string indicating the standardization method used. +If can be: 'parametric' or 'non-parametric'. It is set to 'parametric' by +default.} + +\item{distribution}{A character string indicating the name of the distribution +function to be used for computing the SPEI. The accepted names are: +'log-Logistic' and 'Gamma'. It is set to 'log-Logistic' by default. The +'Gamma' method only works when only precipitation is provided and other + variables are 0 because it is positive defined (SPI indicator).} + +\item{params}{An optional parameter that needs to be a multidimensional array +with named dimensions. This option overrides computation of fitting +parameters. It needs to be of same time dimensions (specified in 'time_dim' +and 'leadtime_dim') of 'data' and a dimension named 'coef' with the length +of the coefficients needed for the used distribution (for 'Gamma' coef +dimension is of lenght 2, for 'log-Logistic' is of length 3). It also needs +to have a leadtime dimension (specified in 'leadtime_dim') of length 1. It +will only be used if 'data_cor' is not provided.} + +\item{return_params}{A logical value indicating wether to return parameters +array (TRUE) or not (FALSE). It is FALSE by default.} + +\item{na.rm}{A logical value indicating whether NA values should be removed +from data. It is FALSE by default. If it is FALSE and there are NA values, +standardization cannot be carried out for those coordinates and therefore, +the result will be filled with NA for the specific coordinates. If it is +TRUE, if the data from other dimensions except time_dim and leadtime_dim is +not reaching 4 values, it is not enough values to estimate the parameters +and the result will include NA.} + +\item{ncores}{An integer value indicating the number of cores to use in +parallel computation.} +} +\value{ +A multidimensional array containing the standardized data. +If 'data_cor' is provided the array will be of the same dimensions as +'data_cor'. If 'data_cor' is not provided, the array will be of the same +dimensions as 'data'. The parameters of the standardization will only be +returned if 'return_params' is TRUE, in this case, the output will be a list +of two objects one for the standardized data and one for the parameters. +} +\description{ +The Standardization of the data is the last step of computing the SPEI +indicator. With this function the data is fit to a probability distribution to +transform the original values to standardized units that are comparable in +space and time and at different SPEI time scales. +} +\details{ +Next, some specifications for the calculation of the standardization will be +discussed. If there are NAs in the data and they are not removed with the +parameter 'na.rm', the standardization cannot be carried out for those +coordinates and therefore, the result will be filled with NA for the +specific coordinates. When NAs are not removed, if the length of the data for +a computational step is smaller than 4, there will not be enough data for +standarize and the result will be also filled with NAs for that coordinates. +About the distribution used to fit the data, there are only two possibilities: +'log-logistic' and 'Gamma'. The 'Gamma' method only works when only +precipitation is provided and other variables are 0 because it is positive +defined (SPI indicator). When only 'data' is provided ('data_cor' is NULL) the +standardization is computed with cross validation. For more information about +SPEI, see functions PeriodPET and PeriodAccumulation. +} +\examples{ +dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) +dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) +data <- array(rnorm(600, -194.5, 64.8), dim = dims) +datacor <- array(rnorm(100, -217.8, 68.29), dim = dimscor) + +SPEI <- PeriodStandardization(data = data) +SPEIcor <- PeriodStandardization(data = data, data_cor = datacor) +} diff --git a/man/PeriodVariance.Rd b/man/PeriodVariance.Rd new file mode 100644 index 0000000000000000000000000000000000000000..9155c4b41009c0af2915fd9b35050adae549a370 --- /dev/null +++ b/man/PeriodVariance.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/PeriodVariance.R +\name{PeriodVariance} +\alias{PeriodVariance} +\title{Period Variance on multidimensional array objects} +\usage{ +PeriodVariance( + data, + dates = NULL, + start = NULL, + end = NULL, + time_dim = "time", + na.rm = FALSE, + ncores = NULL +) +} +\arguments{ +\item{data}{A multidimensional array with named dimensions.} + +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} + +\item{start}{An optional parameter to defined the initial date of the period +to select from the data by providing a list of two elements: the initial +date of the period and the initial month of the period. By default it is set +to NULL and the indicator is computed using all the data provided in +\code{data}.} + +\item{end}{An optional parameter to defined the final date of the period to +select from the data by providing a list of two elements: the final day of +the period and the final month of the period. By default it is set to NULL +and the indicator is computed using all the data provided in \code{data}.} + +\item{time_dim}{A character string indicating the name of the dimension to +compute the indicator. By default, it is set to 'time'. More than one +dimension name matching the dimensions provided in the object +\code{data$data} can be specified.} + +\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or +not (FALSE).} + +\item{ncores}{An integer indicating the number of cores to use in parallel +computation.} +} +\value{ +A multidimensional array with named dimensions containing the +indicator in the element \code{data}. +} +\description{ +Period Variance computes the average (var) of a given variable in a period. +Two bioclimatic indicators can be obtained by using this function: +\itemize{ + \item{'BIO4', (Providing temperature data) Temperature Seasonality + (Standard Deviation). The amount of temperature variation + over a given year (or averaged years) based on the standard + deviation (variation) of monthly temperature averages.} + \item{'BIO15', (Providing precipitation data) Precipitation Seasonality + (CV). This is a measure of the variation in monthly precipitation + totals over the course of the year. This index is the ratio of the + standard deviation of the monthly total precipitation to the mean + monthly total precipitation (also known as the coefficient of + variation) and is expressed as a percentage.} +} +} +\examples{ +data <- array(rnorm(45), dim = c(member = 7, sdate = 4, time = 3)) +Dates <- c(seq(as.Date("2000-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2001-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2001-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2002-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2002-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2003-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month"), + seq(as.Date("2003-11-01", "\%Y-\%m-\%d", tz = "UTC"), + as.Date("2004-01-01", "\%Y-\%m-\%d", tz = "UTC"), by = "month")) +dim(Dates) <- c(sdate = 4, time = 3) +res <- PeriodVariance(data, dates = Dates, start = list(01, 12), end = list(01, 01)) + +} diff --git a/man/QThreshold.Rd b/man/QThreshold.Rd index 2af6e5f93df4ae8e374bdb6211f531d94546ff47..efc48cf5c844fc53977430a22758d2dab177e968 100644 --- a/man/QThreshold.Rd +++ b/man/QThreshold.Rd @@ -23,9 +23,9 @@ QThreshold( units as parameter 'data' and with the common dimensions of the element 'data' of the same length.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -39,7 +39,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} @@ -82,7 +82,17 @@ and memb_dim parameters: \examples{ threshold = 25 data <- array(rnorm(5 * 3 * 20 * 2, mean = 26), - c(member = 5, sdate = 3, time = 20, lon = 2)) -thres_q <- QThreshold(data, threshold) + c(member = 5, sdate = 3, time = 214, lon = 2)) + +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) + +thres_q <- QThreshold(data, threshold, dates = Dates, time_dim = 'time', + start = list(21, 4), end = list(21, 6)) } diff --git a/man/SelectPeriodOnData.Rd b/man/SelectPeriodOnData.Rd index caaa0fb290b86c2c91a7a5793c47865aa1b1982c..2c6181f67a3a232f1d9c3c9a5c5f42b869db3f63 100644 --- a/man/SelectPeriodOnData.Rd +++ b/man/SelectPeriodOnData.Rd @@ -4,7 +4,7 @@ \alias{SelectPeriodOnData} \title{Select a period on Data on multidimensional array objects} \usage{ -SelectPeriodOnData(data, dates, start, end, time_dim = "ftime", ncores = NULL) +SelectPeriodOnData(data, dates, start, end, time_dim = "time", ncores = NULL) } \arguments{ \item{data}{A multidimensional array with named dimensions with at least the @@ -24,7 +24,7 @@ to select from the data. The first element is the final day of the period and the second element is the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. Parameters +compute select the dates. By default, it is set to 'time'. Parameters 'data' and 'dates'} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -40,13 +40,13 @@ Auxiliary function to subset data for a specific period. } \examples{ data <- array(rnorm(5 * 3 * 214 * 2), - c(memb = 5, sdate = 3, ftime = 214, lon = 2)) + c(memb = 5, sdate = 3, time = 214, lon = 2)) Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 214, sdate = 3) +dim(Dates) <- c(time = 214, sdate = 3) Period <- SelectPeriodOnData(data, Dates, start = list(21, 6), end = list(21, 9)) } diff --git a/man/SelectPeriodOnDates.Rd b/man/SelectPeriodOnDates.Rd index 386fb92880f0e6119ed5b9d2c2d2f3ca701f35a3..49ecd9ba82738c8e77c1c8baf1dace5d0e72b69e 100644 --- a/man/SelectPeriodOnDates.Rd +++ b/man/SelectPeriodOnDates.Rd @@ -4,7 +4,7 @@ \alias{SelectPeriodOnDates} \title{Select a period on Dates} \usage{ -SelectPeriodOnDates(dates, start, end, time_dim = "ftime", ncores = NULL) +SelectPeriodOnDates(dates, start, end, time_dim = "time", ncores = NULL) } \arguments{ \item{dates}{An array of dates with named dimensions.} @@ -18,7 +18,7 @@ select from the data by providing a list of two elements: the final day of the period and the final month of the period.} \item{time_dim}{A character string indicating the name of the dimension to -compute select the dates. By default, it is set to 'ftime'. More than one +compute select the dates. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -39,6 +39,6 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) -dim(Dates) <- c(ftime = 214, sdate = 3) +dim(Dates) <- c(time = 214, sdate = 3) Period <- SelectPeriodOnDates(Dates, start = list(21, 6), end = list(21, 9)) } diff --git a/man/Threshold.Rd b/man/Threshold.Rd index db5981753e68504c918674c79c85f87fd2847450..dc9d2a24426af50029823aeeb1f9944df42c66d9 100644 --- a/man/Threshold.Rd +++ b/man/Threshold.Rd @@ -21,11 +21,11 @@ Threshold( \item{data}{A multidimensional array with named dimensions.} \item{threshold}{A single scalar or vector indicating the relative -threshold(s).} +threshold(s). It must contain values between 0 and 1.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -39,7 +39,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the temporal -dimension. By default, it is set to 'ftime'. More than one dimension name +dimension. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified. This dimension is required to subset the data in a requested period.} diff --git a/man/TotalSpellTimeExceedingThreshold.Rd b/man/TotalSpellTimeExceedingThreshold.Rd index 276423bb14092674ee655377d78a89e3a9f8796a..d7815bfab02725637bdddba304b18a5604b88dc1 100644 --- a/man/TotalSpellTimeExceedingThreshold.Rd +++ b/man/TotalSpellTimeExceedingThreshold.Rd @@ -12,7 +12,7 @@ TotalSpellTimeExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", ncores = NULL ) } @@ -36,9 +36,9 @@ are used it has to be a vector of a pair of two logical operators: c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -52,7 +52,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{ncores}{An integer indicating the number of cores to use in parallel @@ -71,9 +71,9 @@ exceed) a threshold are calculated with \code{TotalSpellTimeExceedingThreshold}. This function allows to compute indicators widely used in Climate Services, such as: \itemize{ -\code{WSDI}{Warm Spell Duration Index that count the total number of days - with at least 6 consecutive days when the daily temperature - maximum exceeds its 90th percentile.} + \item{'WSDI', Warm Spell Duration Index that count the total number of days + with at least 6 consecutive days when the daily temperature + maximum exceeds its 90th percentile.} } This function requires the data and the threshold to be in the same units. The 90th percentile can be translate into absolute values given a reference @@ -86,9 +86,19 @@ different behaviour consider to modify the 'data' input by substituting NA values by values exceeding the threshold. } \examples{ -data <- array(rnorm(120), c(member = 1, sdate = 2, ftime = 20, lat = 4)) -threshold <- array(rnorm(4), c(lat = 4)) -total <- TotalSpellTimeExceedingThreshold(data, threshold, spell = 6) +data <- array(1:100, c(member = 5, sdate = 3, time = 214, lon = 2)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) + +threshold <- array(1:4, c(lat = 4)) +total <- TotalSpellTimeExceedingThreshold(data, threshold, dates = Dates, + spell = 6, start = list(21, 4), + end = list(21, 6)) } \seealso{ diff --git a/man/TotalTimeExceedingThreshold.Rd b/man/TotalTimeExceedingThreshold.Rd index 206847574f25df8eabde09914d03bbd2d116bc46..5b9627e75d52687c567be6c34fa8c82923ed916f 100644 --- a/man/TotalTimeExceedingThreshold.Rd +++ b/man/TotalTimeExceedingThreshold.Rd @@ -11,7 +11,7 @@ TotalTimeExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "ftime", + time_dim = "time", na.rm = FALSE, ncores = NULL ) @@ -34,9 +34,9 @@ are used it has to be a vector of a pair of two logical operators: c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to define the initial date of the period to select from the data by providing a list of two elements: the initial @@ -50,7 +50,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. It can only +compute the indicator. By default, it is set to 'time'. It can only indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or @@ -62,7 +62,8 @@ computation.} \value{ A multidimensional array with named dimensions containing the total number of the corresponding units of the data frequency that a variable is -exceeding a threshold during a period. +exceeding a threshold during a period with dimensions of the input parameter +'data' except the dimension where the indicator has been computed. } \description{ The Total Time of a variable exceeding (or not) a Threshold. It returns the @@ -74,20 +75,28 @@ variable units, i.e. to use a percentile as a scalar, the function Providing maximum temperature daily data, the following agriculture indices for heat stress can be obtained by using this function: \itemize{ - \item\code{SU35}{Total count of days when daily maximum temperatures exceed - 35°C in the seven months from the start month given (e.g. - from April to October for start month of April).} - \item\code{SU36}{Total count of days when daily maximum temperatures exceed - 36 between June 21st and September 21st} - \item\code{SU40}{Total count of days when daily maximum temperatures exceed - 40 between June 21st and September 21st} - \item\code{Spr32}{Total count of days when daily maximum temperatures exceed - 32 between April 21st and June 21st} + \item{'SU35', Total count of days when daily maximum temperatures exceed + 35°C in the seven months from the start month given (e.g. from April + to October for start month of April).} + \item{'SU36', Total count of days when daily maximum temperatures exceed + 36 between June 21st and September 21st.} + \item{'SU40', Total count of days when daily maximum temperatures exceed + 40 between June 21st and September 21st.} + \item{'Spr32', Total count of days when daily maximum temperatures exceed + 32 between April 21st and June 21st.} } } \examples{ -exp <- array(abs(rnorm(5 * 3 * 214 * 2)*280), - c(member = 5, sdate = 3, ftime = 214, lon = 2)) -DOT <- TotalTimeExceedingThreshold(exp, threshold = 300, time_dim = 'ftime') +data <- array(rnorm(5 * 3 * 214 * 2)*23, + c(member = 5, sdate = 3, time = 214, lon = 2)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) +DOT <- TotalTimeExceedingThreshold(data, threshold = 23, dates = Dates, + start = list(21, 4), end = list(21, 6)) } diff --git a/man/WindCapacityFactor.Rd b/man/WindCapacityFactor.Rd index 69549a817e3ebd951e3e47e553205699276f95ce..0b6b958109a22efced98cb67b78459c580fed689 100644 --- a/man/WindCapacityFactor.Rd +++ b/man/WindCapacityFactor.Rd @@ -25,9 +25,9 @@ respectively. Classes \code{'I/II'} and \code{'II/III'} indicate intermediate turbines that fit both classes. More details of the five turbines and a plot of its power curves can be found in Lledó et al. (2019).} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -41,7 +41,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -65,8 +65,19 @@ different power curves that span different IEC classes can be selected (see below). } \examples{ -wind <- rweibull(n = 100, shape = 2, scale = 6) -WCF <- WindCapacityFactor(wind, IEC_class = "III") +wind <- array(rweibull(n = 32100, shape = 2, scale = 6), + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) + +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) + +WCF <- WindCapacityFactor(wind, IEC_class = "III", dates = Dates, + start = list(21, 4), end = list(21, 6)) } \references{ diff --git a/man/WindPowerDensity.Rd b/man/WindPowerDensity.Rd index 8e3c8e3d3d147ad0b3cb88c593ad6f390c51e189..9ca3234c3005f61683d6896e1825346179cac9ce 100644 --- a/man/WindPowerDensity.Rd +++ b/man/WindPowerDensity.Rd @@ -22,9 +22,9 @@ speeds expressed in m/s.} dimensions as wind, with the air density expressed in kg/m^3. By default it takes the value 1.225, the standard density of air at 15ºC and 1013.25 hPa.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions matching the dimensions on parameter 'data'. By default it is -NULL, to select a period this parameter must be provided.} +\item{dates}{A multidimensional array of dates with named dimensions matching +the temporal dimensions on parameter 'data'. By default it is NULL, to +select aperiod this parameter must be provided.} \item{start}{An optional parameter to defined the initial date of the period to select from the data by providing a list of two elements: the initial @@ -38,7 +38,7 @@ the period and the final month of the period. By default it is set to NULL and the indicator is computed using all the data provided in \code{data}.} \item{time_dim}{A character string indicating the name of the dimension to -compute the indicator. By default, it is set to 'ftime'. More than one +compute the indicator. By default, it is set to 'time'. More than one dimension name matching the dimensions provided in the object \code{data$data} can be specified.} @@ -57,8 +57,17 @@ It is computed as 0.5*ro*wspd^3. As this function is non-linear, it will give inaccurate results if used with period means. } \examples{ -wind <- rweibull(n = 100, shape = 2, scale = 6) -WPD <- WindPowerDensity(wind) +wind <- array(rweibull(n = 32100, shape = 2, scale = 6), + c(member = 5, sdate = 3, time = 214, lon = 2, lat = 5)) +Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), + as.Date("30-11-2000", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "\%d-\%m-\%Y"), + as.Date("30-11-2001", format = "\%d-\%m-\%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "\%d-\%m-\%Y"), + as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) +dim(Dates) <- c(sdate = 3, time = 214) +WPD <- WindPowerDensity(wind, dates = Dates, start = list(21, 4), + end = list(21, 6)) } \author{ diff --git a/tests/testthat/test-AbsToProbs.R b/tests/testthat/test-AbsToProbs.R index 902b3f11cfd7be18a2ee3d8338388baacac34e1d..c5693df96d218f89433d47d1af0782503c1ae03a 100644 --- a/tests/testthat/test-AbsToProbs.R +++ b/tests/testthat/test-AbsToProbs.R @@ -1,10 +1,8 @@ -context("CSIndicators::AbsToProbs tests") - ############################################## # dat1 dat1 <- NULL dat1$data <- array(rnorm(5 * 2 * 61 * 1), - c(member = 5, sdate = 2, ftime = 61, lon = 1)) + c(member = 5, sdate = 2, time = 61, lon = 1)) Dates1 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), @@ -13,7 +11,7 @@ dat1$attrs$Dates <- Dates1 class(dat1) <- 's2dv_cube' # dat2 Dates2 <- Dates1 -dim(Dates2) <- c(ftime = 61, sdate = 2) +dim(Dates2) <- c(time = 61, sdate = 2) ############################################## test_that("1. Sanity checks", { @@ -55,7 +53,7 @@ test_that("1. Sanity checks", { expect_equal( dim(AbsToProbs(data = dat1$data, dates = Dates2, start = list(21, 4), end = list(21, 6))), - c(member = 5, sdate = 2, ftime = 52, lon = 1) + c(member = 5, sdate = 2, time = 52, lon = 1) ) expect_equal( AbsToProbs(1), diff --git a/tests/testthat/test-AccumulationExceedingThreshold.R b/tests/testthat/test-AccumulationExceedingThreshold.R index a6b598e79df666b4b11e1d3e6c6cd09e3c895d90..2b557767f2bcf082de89fa72b19198c2c8b1e7fb 100644 --- a/tests/testthat/test-AccumulationExceedingThreshold.R +++ b/tests/testthat/test-AccumulationExceedingThreshold.R @@ -1,35 +1,37 @@ -context("CSIndicators::AccumulationExceedingThreshold tests") +############################################## + +library(CSTools) # dat1 dat1 <- 1:20 # dat2 -dat2_1 <- array(1:40, c(x = 2, ftime = 20)) -thres2_1 <- array(10, dim = c(member = 1, ftime = 1)) -dat2_3 <- array(1:20, c(ftime = 5, sdate = 2, lat = 2)) -thres2_3 <- array(1:5, c(ftime = 5)) -dat2_4 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat2_1 <- array(1:40, c(x = 2, time = 20)) +thres2_1 <- array(10, dim = c(member = 1, time = 1)) +dat2_3 <- array(1:20, c(time = 5, sdate = 2, lat = 2)) +thres2_3 <- array(1:5, c(time = 5)) +dat2_4 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) thres2_4 <- array(1:2, c(lat = 2)) # dat3 -dat3_1 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) -dat3_2 <- array(1:40, c(x = 2, ftime = 20)) +dat3_1 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) +dat3_2 <- array(1:40, c(x = 2, time = 20)) # dat4 set.seed(1) -dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat4 <- array(rnorm(60, 23), c(time = 5, fyear = 3, sdate = 2, lat = 2)) set.seed(1) -thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +thres4_1 <- array(rnorm(20, 20), c(time = 5, sdate = 2, lat = 2)) set.seed(2) -thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +thres4_2 <- array(rnorm(20, 25), c(time = 5, sdate = 2, lat = 2)) set.seed(1) -thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +thres4_3 <- array(rnorm(20, 20), c(time = 5, sdate = 2)) set.seed(2) -thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +thres4_4 <- array(rnorm(20, 25), c(time = 5, sdate = 2)) set.seed(1) -thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +thres4_5 <- array(rnorm(5, 20), c(time = 5)) set.seed(2) -thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +thres4_6 <- array(rnorm(5, 25), c(time = 5)) set.seed(1) thres4_7 <- rnorm(5, 20) set.seed(2) @@ -142,19 +144,19 @@ test_that("2. Output checks", { 155 ) expect_equal( - AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'ftime'), + AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'time'), array(c(375, 390), c(x = 2)) ) expect_equal( - AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'ftime'), + AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'time'), array(c(375, 390), c(x = 2)) ) expect_equal( AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'x'), - array(c(rep(0,5), seq(23, 79, 4)), c(ftime = 20)) + array(c(rep(0,5), seq(23, 79, 4)), c(time = 20)) ) expect_equal( - AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'ftime'), + AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'time'), array(c(375, 390), c(x = 2)) ) # dimensions @@ -167,7 +169,7 @@ test_that("2. Output checks", { c(sdate = 2, lat = 2) ) expect_equal( - dim(AccumulationExceedingThreshold(dat2_4, thres2_4, time_dim = 'ftime')), + dim(AccumulationExceedingThreshold(dat2_4, thres2_4, time_dim = 'time')), c(fyear = 3, sdate = 2, lat = 2) ) @@ -189,11 +191,11 @@ test_that("3. Output checks", { array(c(rep(0,10),55,171), dim = c(fyear = 3, sdate = 2, lat = 2)) ) expect_equal( - AccumulationExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'ftime'), + AccumulationExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'time'), array(c(76, 114), c(x = 2)) ) expect_equal( - AccumulationExceedingThreshold(dat3_2, c(7,11), op = c('>=', '<='), time_dim = 'ftime'), + AccumulationExceedingThreshold(dat3_2, c(7,11), op = c('>=', '<='), time_dim = 'time'), array(c(27, 18), c(x = 2)) ) expect_equal( @@ -217,17 +219,17 @@ test_that("4. Output checks", { tolerance = 0.0001 ) expect_equal( - as.vector(AccumulationExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'ftime'))[1:5], + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'time'))[1:5], c(91.05107, 115.67568, 69.89353, 117.29783, 115.40615), tolerance = 0.0001 ) expect_equal( - as.vector(AccumulationExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'ftime'))[1:5], + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'time'))[1:5], c(91.05107, 115.67568, 69.89353, 117.29783, 94.39550), tolerance = 0.0001 ) expect_equal( - as.vector(AccumulationExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'ftime'))[4:10], + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'time'))[4:10], c(117.29783, 94.39550, 113.25711, 90.85402, 91.89458, 115.14699, 116.19438), tolerance = 0.0001 ) @@ -235,7 +237,6 @@ test_that("4. Output checks", { }) ############################################## -library(CSTools) test_that("5. Seasonal forecasts", { exp <- CSTools::lonlat_temp$exp @@ -248,7 +249,7 @@ test_that("5. Seasonal forecasts", { ) # GDD - exp <- array(NA, dim = c(member = 6, sdate = 3, ftime = 214, lat = 4, lon = 4)) + exp <- array(NA, dim = c(member = 6, sdate = 3, time = 214, lat = 4, lon = 4)) exp1 <- drop(CSTools::lonlat_prec$data) * 86400000 exp[, , 1:31, , ] <- exp1 + 10; exp[, , 32:62, , ] <- exp1 + 11 exp[, , 63:93, , ] <- exp1 + 12; exp[, , 94:124, , ] <- exp1 + 13 @@ -261,24 +262,25 @@ test_that("5. Seasonal forecasts", { as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) - GDD <- AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime', + dim(Dates) <- c(sdate = 3, time = 214) + GDD <- AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'time', start = list(1, 4), end = list(31, 10), na.rm = TRUE) expect_equal( round(GDD[,1,1,1]), - c(538, 367, 116, 519, 219, 282) + c(549, 387, 125, 554, 245, 282) ) expect_equal( dim(GDD), - c(member = 6, sdate = 3, lat =4, lon = 4) + c(member = 6, sdate = 3, lat = 4, lon = 4) ) expect_error( - AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, start = list(1, 4), end = list(31, 10), time_dim = 'time'), + AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, start = list(1, 4), end = list(31, 10), time_dim = 'ftime'), "Parameter 'time_dim' is not found in 'data' dimension." ) expect_equal( - all(is.na(AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime',start = list(1, 4), end = list(31, 10)))), - all(is.na(c(NA, NA))) + !any(is.na(AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'time',start = list(1, 4), end = list(31, 10)))), + !any(is.na(c(1, 1))) ) # test the 'diff' @@ -295,7 +297,6 @@ test_that("5. Seasonal forecasts", { AccumulationExceedingThreshold(input_1, threshold_1), 204 ) - expect_equal( AccumulationExceedingThreshold(input_2, threshold_2, op = '<'), -105 @@ -305,3 +306,47 @@ test_that("5. Seasonal forecasts", { -55 ) }) + +############################################## +test_that("6. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_AccumulationExceedingThreshold(data = exp, threshold = mean(exp$data), + time_dim = 'ftime', start = list(10, 03), + end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) diff --git a/tests/testthat/test-MergeRefToExp.R b/tests/testthat/test-MergeRefToExp.R index 2c3e8f65637be858ef835dd10ba07e9e4a871938..bce58279d03e2d314a3918eecf66487fde8bd3ad 100644 --- a/tests/testthat/test-MergeRefToExp.R +++ b/tests/testthat/test-MergeRefToExp.R @@ -1,59 +1,242 @@ -context("CSIndicators::MergeRefToExp tests") +########################################################################### + +# cube1 +dates_data1 <- c(seq(as.Date("11-07-1993", "%d-%m-%Y", tz = 'UTC'), + as.Date("20-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("11-07-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("20-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) +dim(dates_data1) <- c(time = 10, sdate = 2) +cube1 <- NULL +cube1$data <- array(1:(2*10*2), c(time = 10, sdate = 2, member = 2)) +cube1$attrs$Dates <- dates_data1 +class(cube1) <- 's2dv_cube' +ref_dates1 <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), + as.Date("10-07-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("10-07-1994","%d-%m-%Y", tz = 'UTC'), "day")) +dim(ref_dates1) <- c(time = 10, sdate = 2) +cube_ref <- NULL +cube_ref$data <- array(1001:1020, c(time = 10, sdate = 2)) +cube_ref$attrs$Dates <- ref_dates1 +class(cube_ref) <- 's2dv_cube' +start1 <- list(3, 7) +end1 <- list(10, 7) +start2 <- list(11, 7) +end2 <- list(15, 7) + +# dat1 +ref1 <- array(1001:1020, c(time = 10, sdate = 2, member = 1)) +data1 <- array(1:40, c(time = 10, sdate = 2, member = 2)) + + +# dat2 +ref2 <- array(1001:1015, c(time = 5, sdate = 1, member = 3)) +data2 <- array(1:6, c(time = 3, sdate = 1, member = 2)) ########################################################################### +test_that("1. Input checks", { + # 's2dv_cube' + expect_error( + CST_MergeRefToExp('a'), + "Parameter 'data1' must be of the class 's2dv_cube'." + ) + expect_error( + CST_MergeRefToExp(cube1, array(10)), + "Parameter 'data2' must be of the class 's2dv_cube'." + ) + # data + expect_error( + MergeRefToExp(10, 10), + "Parameters 'data1' and 'data2' must be arrays." + ) + expect_error( + MergeRefToExp(array(10), array(10)), + "Parameters 'data1' and 'data2' must have named dimensions." + ) + # time_dim + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, time_dim = 'ftime'), + paste0("Parameter 'time_dim' is not found in 'data1' or 'data2' dimension ", + "names.") + ) + # memb_dim + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, memb_dim = 1), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + MergeRefToExp(data1 = ref1, data2 = data1, memb_dim = 'ensemble'), + paste0("Parameter 'memb_dim' is not found in 'data1' or 'data2' dimension. ", + "Set it to NULL if there is no member dimension.") + ) + # common dimensions + expect_error( + MergeRefToExp(data1 = array(1:12, c(sdate = 2, time = 2, dat = 3)), + data2 = array(1:16, c(sdate = 2, time = 2, var = 4)), + memb_dim = NULL), + paste0("Parameter 'data1' and 'data2' must have same length of ", + "all dimensions except 'memb_dim'.") + ) + expect_error( + MergeRefToExp(data1 = array(1:12, c(sdate = 2, time = 2, dat = 1)), + data2 = array(1:16, c(sdate = 2, time = 2)), + memb_dim = NULL), + paste0("Parameter 'data1' and 'data2' must have same length of ", + "all dimensions except 'memb_dim'.") + ) + # dates + expect_warning( + MergeRefToExp(data1 = array(1:4, c(sdate = 2, time = 2, lat = 1)), + data2 = array(1:16, c(sdate = 2, time = 2, lat = 1)), + memb_dim = NULL, start1 = list(1, 1), end1 = list(3, 1), + start2 = NULL, end2 = NULL), + paste0("Parameter 'dates' is NULL and the average of the ", + "full data provided in 'data' is computed.") + ) + expect_warning( + MergeRefToExp(data1 = ref1, + data2 = data1, dates1 = ref_dates1, dates2 = dates_data1, + start1 = c(3, 7), end1 = end1, + start2 = start2, end2 = end2), + paste0("Parameter 'start1' and 'end1' must be lists indicating the ", + "day and the month of the period start and end. Full data ", + "will be used.") + ) + expect_warning( + MergeRefToExp(data1 = ref1, + data2 = data1, dates1 = as.vector(ref_dates1), + dates2 = dates_data1, start1 = start1, end1 = end1, + start2 = start2, end2 = end2), + paste0("Parameter 'dates1' must have named dimensions if 'start' and ", + "'end' are not NULL. All 'data1' will be used.") + ) +}) -test_that("Sanity checks", { +########################################################################### + +test_that("2. Output checks: CST_MergeRefToExp", { + res1 <- CST_MergeRefToExp(data1 = cube_ref, data2 = cube1, + start1 = start1, end1 = end1, + start2 = start2, end2 = end2) + # dims + expect_equal( + dim(res1$data), + res1$dims + ) + # coords + expect_equal( + names(dim(res1$data)), + names(res1$coords) + ) + # Dates + expect_equal( + dim(res1$data)[c('time', 'sdate')], + dim(res1$attrs$Dates) + ) + # data + expect_equal( + res1$data[1:8,,1], + res1$data[1:8,,2] + ) +}) + +########################################################################### + +test_that("3. Output checks: MergeRefToExp", { + # Minimum dimensions + expect_equal( + MergeRefToExp(data1 = array(1:2, c(time = 2)), + data2 = array(1, c(time = 1)), memb_dim = NULL), + array(c(1,2,1), dim = c(time = 3)) + ) + # res2 + res2 <- MergeRefToExp(data1 = ref1, data2 = data1) + ## dims + expect_equal( + dim(res2), + c(time = 20, sdate = 2, member = 2) + ) + ## data + expect_equal( + res2[,1,], + array(c(1001:1010, 1:10, 1001:1010, 21:30), dim = c(time = 20, member = 2)) + ) + # res3: multiple different members + res3 <- MergeRefToExp(data1 = ref2, data2 = data2) + ## dims + expect_equal( + dim(res3), + c(time = 8, sdate = 1, member = 6) + ) + expect_equal( + as.vector(res3[1:5, 1, ]), + c(rep(1001:1005, 2), rep(1006:1010, 2), rep(1011:1015, 2)) + ) + expect_equal( + as.vector(res3[6:8, 1, ]), + rep(c(1:3, 4:6), 3) + ) +}) + +########################################################################### + +test_that("3. Output checks: Dates", { data_dates <- c(seq(as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1993", "%d-%m-%Y", tz = 'UTC'), "day"), seq(as.Date("01-07-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day")) - dim(data_dates) <- c(ftime = 154, sdate = 2) + dim(data_dates) <- c(time = 154, sdate = 2) ref_dates <- seq(as.Date("01-01-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-12-1994", "%d-%m-%Y", tz = 'UTC'), "day") - dim(ref_dates) <- c(ftime = 350, sdate = 2) + dim(ref_dates) <- c(time = 350, sdate = 2) ref <- NULL - ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) + ref$data <- array(1001:1700, c(time = 350, sdate = 2)) ref$attrs$Dates <- ref_dates class(ref) <- 's2dv_cube' data <- NULL - data$data <- array(1:(2 * 154 * 2), c(ftime = 154, sdate = 2, member= 2)) + data$data <- array(1:(2 * 154 * 2), c(time = 154, sdate = 2, member= 2)) data$attrs$Dates <- data_dates class(data) <- 's2dv_cube' -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), - end1 = list(30, 6), start2 = list(1, 7), - end2 = list(21, 9))$attrs$Dates, - SelectPeriodOnDates(ref_dates, start = list(21, 6), end = list(21,9))) -) + suppressWarnings( + expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), + end1 = list(30, 6), start2 = list(1, 7), + end2 = list(21, 9))$attrs$Dates, + SelectPeriodOnDates(ref_dates, start = list(21, 6), end = list(21,9))) + ) output <- array(c(1172:1181, 1:83, 1537:1546, 155:237, 1172:1181, 309:391, - 1537:1546, 463:545), c(ftime = 93, sdate = 2, member = 2)) + 1537:1546, 463:545), c(time = 93, sdate = 2, member = 2)) expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), end1 = list(30, 6), start2 = list(1, 7), end2 = list(21, 9))$data, - output) + output + ) # issue 13: One lead time data_dates <- c(as.Date("01-06-1993", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), + as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-06-1994", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) + as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) - dim(data_dates) <- c(ftime = 2, sdate = 2) + dim(data_dates) <- c(time = 2, sdate = 2) ref_dates <- c(as.Date("01-05-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-05-1994", "%d-%m-%Y", tz = 'UTC')) - dim(ref_dates) <- c(ftime = 1, sdate = 2) + dim(ref_dates) <- c(time = 1, sdate = 2) ref <- NULL - ref$data <- array(1:2, c(ftime = 1, sdate = 2)) + ref$data <- array(1:2, c(time = 1, sdate = 2)) ref$attrs$Dates <- ref_dates class(ref) <- 's2dv_cube' data <- NULL - data$data <- array(1:(2 * 3 * 2), c(ftime = 2, sdate = 2, member = 3)) + data$data <- array(1:(2 * 3 * 2), c(time = 2, sdate = 2, member = 3)) data$attrs$Dates <- data_dates class(data) <- 's2dv_cube' @@ -63,8 +246,7 @@ suppressWarnings( as.Date("01-05-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-06-1994", "%d-%m-%Y", tz = 'UTC'), as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) - dim(res_dates) <- c(ftime = 3, sdate = 2) - + dim(res_dates) <- c(time = 3, sdate = 2) expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), @@ -75,7 +257,7 @@ suppressWarnings( output <- abind::abind(t(matrix(rep(1:2, 3), ncol = 2, nrow = 3, byrow = T)), data$data, along = 1) - names(dim(output)) <- c('ftime', 'sdate', 'member') + names(dim(output)) <- c('time', 'sdate', 'member') expect_equal( CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), @@ -83,11 +265,11 @@ suppressWarnings( end2 = list(31, 7))$data, output ) - }) -test_that("Seasonal", { +########################################################################### +test_that("4. Test Seasonal", { dates <- NULL hcst.inityear <- 1993 hcst.endyear <- 2017 @@ -95,19 +277,18 @@ test_that("Seasonal", { dates <- c(dates, format(seq(as.Date(paste0("01-04-",year), "%d-%m-%Y", tz = 'UTC'), as.Date(paste0("01-11-",year), "%d-%m-%Y", - tz = 'UTC'), "day"), - "%Y-%m-%d")) + tz = 'UTC'), "day"), "%Y-%m-%d")) } dates <- as.Date(dates, tz = 'UTC') - dim.dates <- c(ftime=215, sweek = 1, sday = 1, - sdate=(hcst.endyear-hcst.inityear)+1) + dim.dates <- c(time = 215, sweek = 1, sday = 1, + sdate = (hcst.endyear - hcst.inityear) + 1) dim(dates) <- dim.dates ref <- NULL - ref$data <- array(1:(215*25), c(ftime = 215, sdate = 25)) + ref$data <- array(1:(215*25), c(time = 215, sdate = 25)) ref$attrs$Dates <- dates class(ref) <- 's2dv_cube' data <- NULL - data$data <- array(1:(215*25*3), c(ftime = 215, sdate = 25, member=3)) + data$data <- array(1:(215*25*3), c(time = 215, sdate = 25, member=3)) data$attrs$Dates <- dates class(data) <- 's2dv_cube' diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 777dc30cbe09cb21109d1d9506a2922563d8127f..9dcbcf9c44cb96b10cbe0c520e875e7ad70dfd8e 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -1,24 +1,72 @@ -context("CSIndicators::PeriodAccumulation tests") +library(CSTools) + +# dat1 +dat1 <- array(1:6, dim = c(sdate = 2, ftime = 3, member = 1)) +dat1_1 <- dat1 +class(dat1_1) <- 's2dv_cube' +dat1_2 <- NULL +dat1_2$data <- dat1 +class(dat1_2) <- 's2dv_cube' + +# dat2 +dat2 <- array(1:6, dim = c(sdate = 2, time = 3, member = 1)) +dates2 <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("03-04-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("03-04-2001", format = "%d-%m-%Y"), by = 'day')) +dim(dates2) <- c(time = 3, sdate = 2) -test_that("Sanity Checks", { +# exp1 +exp <- NULL +exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, ftime = 214, lon = 2)) +exp$dims <- dim(exp$data) +exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) +dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +class(exp) <- 's2dv_cube' + +############################################## +test_that("1. Initial checks", { + # s2dv_cube expect_error( - PeriodAccumulation('x'), - "Parameter 'data' must be numeric." + CST_PeriodAccumulation(array(1)), + "Parameter 'data' must be of the class 's2dv_cube'." ) - expect_equal( - PeriodAccumulation(1), - 1 + expect_error( + CST_PeriodAccumulation(data = dat1_1, start = list(1,2), end = list(2,3)), + "Parameter 'data' doesn't have 's2dv_cube' structure. Use PeriodAccumulation instead." ) - expect_equal( - PeriodAccumulation(1, time_dim = 'x'), - 1 + # Dates subset + expect_warning( + CST_PeriodAccumulation(data = dat1_2, start = list(1,2), end = list(2,3), + time_dim = 'ftime'), + paste0("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used."), + fixed = TRUE + ) + # data + expect_error( + PeriodAccumulation('x'), + "Parameter 'data' must be numeric." ) expect_error( PeriodAccumulation(data = NULL), "Parameter 'data' cannot be NULL." ) + # time_dim expect_error( - PeriodAccumulation(1, dates = '2000-01-01', end = 3, start = 4), + PeriodAccumulation(data = dat2, time_dim = 'ftime', rollwidth = 1, + dates = dates2), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # start and end + expect_error( + PeriodAccumulation(dat2, dates = '2000-01-01', end = 3, start = 4), paste("Parameter 'start' and 'end' must be lists indicating", "the day and the month of the period start and end.") ) @@ -31,23 +79,27 @@ test_that("Sanity Checks", { PeriodAccumulation(data), array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4)) ) - + # Test dates warning + expect_warning( + PeriodAccumulation(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodAccumulation(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) + ############################################## -library(CSTools) -test_that("seasonal", { - exp <- CSTools::lonlat_prec - exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) - exp$dims <- dim(exp$data) - exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), - as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2001", format = "%d-%m-%Y"), - as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), - seq(as.Date("01-04-2002", format = "%d-%m-%Y"), - as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) +test_that("2. Seasonal", { output <- exp output$data <- array(c(sum(exp$data[1,1,21:82,1]), sum(exp$data[1,2,21:82,1]), sum(exp$data[1,3,21:82,1]), sum(exp$data[1,1,21:82,2]), @@ -55,7 +107,118 @@ test_that("seasonal", { c(memb = 1, sdate = 3, lon = 2)) expect_equal( - CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6))$data, + CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6), + time_dim = 'ftime')$data, output$data ) }) + +############################################## + +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodAccumulation(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + res2 <- CST_PeriodAccumulation(data = CSTools::lonlat_prec, time_dim = 'ftime') + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + expect_equal( + dim(res2$data), + dim(exp$data)[-which(names(dim(exp$data)) == 'ftime')] + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + expect_equal( + dim(res2$data)['sdate'], + dim(res2$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + expect_equal( + res2$attrs$Dates, + res2$attrs$time_bounds$start + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + +############################################## + +test_that("4. Rolling", { + # dates + expect_error( + PeriodAccumulation(data = dat2, rollwidth = 1), + "Parameter 'dates' is NULL. Cannot compute the rolling accumulation." + ) + # rollwidth + expect_error( + PeriodAccumulation(data = dat2, rollwidth = 'a', dates = dates2), + "Parameter 'rollwidth' must be a numeric value." + ) + expect_error( + PeriodAccumulation(data = dat2, rollwidth = 5, dates = dates2), + "Cannot compute accumulation of 5 months because loaded data has only 3 months." + ) + # sdate_dim + expect_error( + PeriodAccumulation(data = dat2, rollwidth = 1, dates = dates2, + sdate_dim = 'syear'), + "Parameter 'sdate_dim' is not found in 'data' dimension." + ) + # Output checks + expect_equal( + PeriodAccumulation(data = dat2, rollwidth = -2, dates = dates2, frequency = 'daily'), + array(c(4,6,8, 10, NA, NA), dim = c(sdate = 2, time = 3, member = 1)) + ) + expect_equal( + PeriodAccumulation(data = dat2, rollwidth = 3, dates = dates2, frequency = 'daily'), + array(c(rep(NA, 4), 9, 12), dim = c(sdate = 2, time = 3, member = 1)) + ) + dat2_1 <- dat2 + dat2_1[1,1,1] <- NA + expect_equal( + PeriodAccumulation(data = dat2_1, rollwidth = 2, dates = dates2, na.rm = FALSE, + frequency = 'daily'), + array(c(rep(NA, 3), 6,8,10), dim = c(sdate = 2, time = 3, member = 1)) + ) + + # Test rolling with start and end + expect_equal( + PeriodAccumulation(data = dat2, rollwidth = 1, dates = dates2, + start = list(1, 4), end = list(2, 4), frequency = 'daily'), + array(c(1, 2, 3, 4), dim = c(sdate = 2, time = 2, member = 1)) + ) + expect_equal( + PeriodAccumulation(data = dat2, rollwidth = 2, dates = dates2, + start = list(1, 4), end = list(2, 4), frequency = 'daily'), + array(c(NA, NA, 4, 6), dim = c(sdate = 2, time = 2, member = 1)) + ) +}) diff --git a/tests/testthat/test-PeriodMax.R b/tests/testthat/test-PeriodMax.R new file mode 100644 index 0000000000000000000000000000000000000000..1d7437a40f90f272e7740ef0c4a838bb77cb72ea --- /dev/null +++ b/tests/testthat/test-PeriodMax.R @@ -0,0 +1,133 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + # data + expect_error( + PeriodMax(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + PeriodMax('x'), + "Parameter 'data' must be numeric." + ) + # time_dim + expect_error( + PeriodMax(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodMax(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + suppressWarnings( + expect_equal( + PeriodMax(array(1, c(x = 1)), time_dim = 'x'), + 1 + ) + ) + expect_error( + PeriodMax(1, dates = '2000-01-01', end = 3, start = 4), + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) + suppressWarnings( + expect_equal( + PeriodMax(array(1:10, c(time = 10))), + 10 + ) + ) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) + suppressWarnings( + expect_equal( + PeriodMax(data), + array(c(5, 6, 11, 12, 17, 18, 23, 24), + c(sdate = 2, lon = 4)) + ) + ) + # Test dates warning + expect_warning( + PeriodMax(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodMax(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, time = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(max(exp$data[1,1,21:82,1]), max(exp$data[1,2,21:82,1]), + max(exp$data[1,3,21:82,1]), max(exp$data[1,1,21:82,2]), + max(exp$data[1,2,21:82,2]), max(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodMax(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMax(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index 7576b1139ea2d05a7dbf2487012f99ac75e51712..9f8c4cf15faa16229c2ccf223ee3df350c1e72ee 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -1,6 +1,8 @@ -context("CSIndicators::PeriodMean tests") +library(CSTools) -test_that("Sanity Checks", { +############################################## +test_that("1. Sanity Checks", { + # data expect_error( PeriodMean('x'), "Parameter 'data' must be numeric." @@ -15,9 +17,19 @@ test_that("Sanity Checks", { PeriodMean(data = NULL), "Parameter 'data' cannot be NULL." ) + # time_dim + expect_error( + PeriodMean(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodMean(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) expect_error( PeriodMean(1, dates = '2000-01-01', end = 3, start = 4), - "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end.") + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) suppressWarnings( expect_equal( PeriodMean(array(1:10, c(time = 10))), @@ -32,15 +44,30 @@ test_that("Sanity Checks", { c(sdate = 2, lon = 4)) ) ) + # Test dates warning + expect_warning( + PeriodMean(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodMean(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ############################################## -library(CSTools) -test_that("seasonal", { - exp <- CSTools::lonlat_prec +test_that("2. Seasonal", { + exp <- NULL exp$data <- array(1:(1 * 3 * 214 * 2), - c(memb = 1, sdate = 3, ftime = 214, lon = 2)) + c(memb = 1, sdate = 3, time = 214, lon = 2)) exp$dims <- dim(exp$data) exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), @@ -48,7 +75,8 @@ test_that("seasonal", { as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2002", format = "%d-%m-%Y"), as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) - dim(exp$attrs$Dates) <- c(ftime = 214, sdate = 3) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) + class(exp) <- 's2dv_cube' output <- exp output$data <- array(c(mean(exp$data[1,1,21:82,1]), mean(exp$data[1,2,21:82,1]), mean(exp$data[1,3,21:82,1]), mean(exp$data[1,1,21:82,2]), @@ -59,3 +87,47 @@ test_that("seasonal", { output$data ) }) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMean(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-PeriodMin.R b/tests/testthat/test-PeriodMin.R new file mode 100644 index 0000000000000000000000000000000000000000..fb97fc206681fcbcb773e42dab4aa5f0af3b9449 --- /dev/null +++ b/tests/testthat/test-PeriodMin.R @@ -0,0 +1,129 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + # data + expect_error( + PeriodMin('x'), + "Parameter 'data' must be numeric." + ) + suppressWarnings( + expect_equal( + PeriodMin(array(1, c(x = 1)), time_dim = 'x'), + 1 + ) + ) + expect_error( + PeriodMin(data = NULL), + "Parameter 'data' cannot be NULL." + ) + # time_dim + expect_error( + PeriodMin(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodMin(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodMin(1, dates = '2000-01-01', end = 3, start = 4), + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) + expect_equal( + PeriodMin(array(1:10, c(time = 10))), + 1 + ) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) + expect_equal( + PeriodMin(data), + array(c(1, 2, 7, 8, 13, 14, 19, 20), + c(sdate = 2, lon = 4)) + ) + # Test dates warning + expect_warning( + PeriodMin(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodMin(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, time = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(min(exp$data[1,1,21:82,1]), min(exp$data[1,2,21:82,1]), + min(exp$data[1,3,21:82,1]), min(exp$data[1,1,21:82,2]), + min(exp$data[1,2,21:82,2]), min(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodMin(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMin(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-PeriodPET.R b/tests/testthat/test-PeriodPET.R new file mode 100644 index 0000000000000000000000000000000000000000..632d1c48ac6a7b77af048488646108e25b7d49d0 --- /dev/null +++ b/tests/testthat/test-PeriodPET.R @@ -0,0 +1,197 @@ +############################################## + +# cube1 +cube1 <- NULL +cube1$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube1) <- 's2dv_cube' + +# cube2 +cube2 <- NULL +cube2$data <- array(rnorm(10), dim = c(lat = 2, time = 5)) +class(cube2) <- 's2dv_cube' +cube2$coords <- list(lat = 1:2) + +# dat1 +dims <- c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) + +set.seed(1) +exp_tasmax <- array(rnorm(360, 27.73, 5.26), dim = dims) +set.seed(2) +exp_tasmin <- array(rnorm(360, 14.83, 3.86), dim = dims) +set.seed(3) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims) + +dates_exp <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates_exp) <- c(syear = 6, time = 3) + +lat <- c(40,40.1) + +exp1 <- list('tmax' = exp_tasmax, 'tmin' = exp_tasmin, 'pr' = exp_prlr) + +# dat2 +dims2 <- c(styear = 6, ftime = 3, lat = 2, lon = 1, member = 10) + +set.seed(1) +exp_tas <- array(rnorm(100, 17.34, 9.18), dim = dims2) +set.seed(2) +exp_prlr <- array(rnorm(360, 21.19, 25.64), dim = dims2) + +dates_exp2 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates_exp2) <- c(sday = 1, sweek = 1, styear = 6, ftime = 3) + +lat <- c(40,40.1) + +exp2 <- list('tmean' = exp_tas, 'pr' = exp_prlr) + +# cube4 +cube4_exp <- lapply(exp1, function(x) { + suppressWarnings( + CSTools::s2dv_cube(data = x, coords = list(latitude = c(40, 40.1)), + varName = 'test', Dates = as.POSIXct(dates_exp)) + ) +}) + +############################################## + +test_that("1. Initial checks CST_PeriodPET", { + # Check 's2dv_cube' + expect_error( + CST_PeriodPET(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + CST_PeriodPET(data = array(10)), + "Parameter 'data' must be a list of 's2dv_cube' class." + ) + # latitude + expect_error( + CST_PeriodPET(data = list(cube1)), + paste0("Spatial coordinate names of parameter 'data' do not match any ", + "of the names accepted by the package.") + ) + # Dates + expect_error( + CST_PeriodPET(data = list(cube2)), + paste0("Element 'Dates' is not found in 'attrs' list of 'data'. ", + "See 's2dv_cube' object description in README file for more ", + "information.") + ) +}) + +############################################## + +test_that("1. Initial checks PeriodPET", { + # data + expect_error( + PeriodPET(data = NULL), + "Parameter 'data' needs to be a named list with the needed variables." + ) + expect_error( + PeriodPET(data = list(1)), + "Parameter 'data' needs to be a named list with the variable names." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10))), + "Parameter 'data' needs to be a list of arrays with dimension names." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 11)))), + "Parameter 'data' variables need to have the same dimensions." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(ftime = 10)))), + "Parameter 'data' variables need to have the same dimensions." + ) + # lat + expect_error( + PeriodPET(data = exp1, lat = 'lat'), + "Parameter 'lat' must be numeric." + ) + expect_error( + PeriodPET(data = list(tasmax = array(10, c(time = 10)), + tasmin = array(10, c(time = 10))), lat = 1:2), + "Parameter 'data' must have 'lat_dim' dimension." + ) + # data (2) + expect_warning( + PeriodPET(data = exp1, pet_method = '1', dates = dates_exp, lat = lat), + paste0("Parameter 'pet_method' needs to be 'hargreaves' or ", + "'hargreaves_modified'. It is set to 'hargreaves_modified'.") + ) + # time_dim + expect_error( + PeriodPET(data = exp1, time_dim = 1, dates = dates_exp, lat = lat), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodPET(data = exp2, lat = lat, dates = dates_exp2, + lat_dim = 'lat', pet_method = 'thornthwaite'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # leadtime_dim + expect_error( + PeriodPET(data = exp1, leadtime_dim = 1, dates = dates_exp, lat = lat), + "Parameter 'leadtime_dim' must be a character string." + ) + expect_error( + PeriodPET(data = exp2, lat = lat, dates = dates_exp2, + lat_dim = 'lat', time_dim = 'ftime', pet_method = 'thornthwaite'), + "Parameter 'leadtime_dim' is not found in 'data' dimension." + ) + # lat_dim + expect_error( + PeriodPET(data = exp1, lat_dim = 1, dates = dates_exp, lat = lat) + ) + expect_error( + PeriodPET(data = exp2, lat = lat, dates = dates_exp2), + "Parameter 'data' must have 'lat_dim' dimension." + ) + # na.rm + expect_error( + PeriodPET(data = exp1, na.rm = 1.5, dates = dates_exp, lat = lat), + "Parameter 'na.rm' must be one logical value." + ) + # ncores + expect_error( + PeriodPET(data = exp1, ncores = 1.5, dates = dates_exp, lat = lat), + "Parameter 'ncores' must be a positive integer." + ) +}) + +############################################## + +test_that("2. Output checks", { + res01 <- CST_PeriodPET(data = cube4_exp) + res1 <- PeriodPET(data = exp1, lat = lat, dates = dates_exp) + res2 <- PeriodPET(data = exp2, lat = lat, dates = dates_exp2, + pet_method = c('thornthwaite'), + lat_dim = 'lat', time_dim = 'styear', + leadtime_dim = 'ftime') + # structure + expect_equal( + names(res01), + c('data', 'dims', 'coords', 'attrs') + ) + # dims + expect_equal( + dim(res1), + c(syear = 6, time = 3, latitude = 2, longitude = 1, ensemble = 10) + ) + # values + expect_equal( + res1[1:4], + c(137.77342, 154.55548, 65.72859, 222.20438), + tolerance = 0.0001 + ) + expect_equal( + res2[1:4], + c(77.76124, 118.94212, 66.57568, 185.67074), + tolerance = 0.0001 + ) +}) + +############################################## \ No newline at end of file diff --git a/tests/testthat/test-PeriodStandardization.R b/tests/testthat/test-PeriodStandardization.R new file mode 100644 index 0000000000000000000000000000000000000000..7673db2d070cef7f71506bf80acbef78694ae42e --- /dev/null +++ b/tests/testthat/test-PeriodStandardization.R @@ -0,0 +1,230 @@ +############################################## + +# cube1 +dims <- c(syear = 6, time = 3, latitude = 2, ensemble = 25) +cube1 <- NULL +cube1$data <- array(rnorm(600, -204.1, 78.1), dim = dims) +class(cube1) <- 's2dv_cube' + +# dat1 +dims <- c(syear = 6, time = 2, latitude = 2, ensemble = 25) +dimscor <- c(syear = 1, time = 2, latitude = 2, ensemble = 25) +dimscor1_1 <- c(syear = 1, time = 3, latitude = 2, ensemble = 25) +set.seed(1) +dat1 <- array(rnorm(600, -194.5, 64.8), dim = dims) +set.seed(2) +datcor1 <- array(rnorm(100, -217.8, 68.29), dim = dimscor) +set.seed(3) +datcor1_1 <- array(rnorm(100, -217.8, 68.29), dim = dimscor1_1) + +# dates1 +dates1 <- as.Date(c(paste0(2010:2015, "-08-16"), paste0(2010:2015, "-09-15"), + paste0(2010:2015, "-10-16"))) +dim(dates1) <- c(syear = 6, time = 3) + +# dat2 +dims2 <- c(styear = 6, ftime = 2, lat = 2, member = 25) +dimscor2_1 <- c(syear = 1, ftime = 2, lat = 2, ensemble = 25) +dimscor2_2 <- c(styear = 1, ftime = 2, lat = 2, ensemble = 25) +set.seed(1) +dat2 <- array(rnorm(600, -194.5, 64.8), dim = dims2) +set.seed(2) +datcor2_1 <- array(rnorm(100, -194.5, 64.8), dim = dimscor2_1) +set.seed(2) +datcor2_2 <- array(rnorm(100, -194.5, 64.8), dim = dimscor2_2) + +# dat3 +dims3 <- c(syear = 6, time = 2, lat = 2, ensemble = 25) +set.seed(1) +dat3 <- array(abs(rnorm(600, 21.19, 25.64)), dim = dims) + + +############################################## + +test_that("1. Initial checks CST_PeriodStandardization", { + # Check 's2dv_cube' + expect_error( + CST_PeriodStandardization(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + CST_PeriodStandardization(data = array(10)), + "Parameter 'data' must be of 's2dv_cube' class." + ) +}) + +############################################## + +test_that("1. Initial checks PeriodStandardization", { + # data + expect_error( + PeriodStandardization(data = NULL), + "Parameter 'data' must be a numeric array." + ) + expect_error( + PeriodStandardization(data = array(1)), + "Parameter 'data' must have dimension names." + ) + # data_cor + expect_error( + PeriodStandardization(data = dat1, data_cor = 1), + "Parameter 'data_cor' must be a numeric array." + ) + expect_error( + PeriodStandardization(data = dat1, data_cor = array(1:2)), + "Parameter 'data_cor' must have dimension names." + ) + # time_dim + expect_error( + PeriodStandardization(data = dat1, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodStandardization(data = dat2), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodStandardization(data = dat2, data_cor = dat1, time_dim = 'ftime'), + "Parameter 'time_dim' is not found in 'data_cor' dimension." + ) + # leadtime_dim + expect_error( + PeriodStandardization(data = dat1, leadtime_dim = 1), + "Parameter 'leadtime_dim' must be a character string." + ) + expect_error( + PeriodStandardization(data = dat2, time_dim = 'ftime'), + "Parameter 'leadtime_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodStandardization(data = dat2, data_cor = datcor2_1, time_dim = 'ftime', + leadtime_dim = 'styear'), + "Parameter 'leadtime_dim' is not found in 'data_cor' dimension." + ) + # memb_dim + expect_error( + PeriodStandardization(data = dat1, memb_dim = 1), + "Parameter 'memb_dim' must be a character string." + ) + expect_error( + PeriodStandardization(data = dat2, time_dim = 'styear', leadtime_dim = 'ftime'), + "Parameter 'memb_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodStandardization(data = dat2, data_cor = datcor2_2, time_dim = 'styear', + leadtime_dim = 'ftime', memb_dim = 'member'), + "Parameter 'memb_dim' is not found in 'data_cor' dimension." + ) + # data_cor (2) + expect_error( + PeriodStandardization(data = dat1, data_cor = datcor1_1), + paste0("Parameter 'data' and 'data_cor' have dimension 'leadtime_dim' ", + "of different length.") + ) + # ref_period + expect_warning( + PeriodStandardization(data = dat1, ref_period = list(1,2)), + paste0("Parameter 'dates' is not provided so 'ref_period' can't be ", + "used.") + ) + expect_warning( + PeriodStandardization(data = dat1, ref_period = list(2020, 2021), + dates = dates1), + paste0("Parameter 'ref_period' contain years outside the dates. ", + "It will not be used.") + ) + # handle_infinity + # method + # distribution + # na.rm + expect_error( + PeriodStandardization(data = dat1, na.rm = 1.5), + "Parameter 'na.rm' must be logical." + ) + # ncores + expect_error( + PeriodStandardization(data = dat1, ncores = 1.5), + "Parameter 'ncores' must be a positive integer." + ) +}) + +############################################## + +test_that("2. Output checks", { + # CST_PeriodStandardization + SPEI_s2dv_cube <- CST_PeriodStandardization(data = cube1) + expect_equal( + names(SPEI_s2dv_cube), + c('data', 'attrs') + ) + # PeriodStandardization + SPEI <- PeriodStandardization(data = dat1) + expect_equal( + dim(SPEI), + c(syear = 6, time = 2, latitude = 2, ensemble = 25) + ) + expect_equal( + SPEI[,1,1,1], + c(-0.4842599, 0.4072574, -0.8119087, 1.5490196, 0.5467044, -0.7719460), + tolerance = 0.0001 + ) + SPEIcor <- PeriodStandardization(data = dat1, data_cor = datcor1) + expect_equal( + dim(SPEIcor), + c(syear = 1, time = 2, latitude = 2, ensemble = 25) + ) + expect_equal( + SPEIcor[,,1,1], + c(-1.232981, -0.309125), + tolerance = 0.0001 + ) + # time_dim, leadtime_dim, memb_dim + expect_equal( + PeriodStandardization(data = dat2, time_dim = 'ftime', + leadtime_dim = 'styear', memb_dim = 'member')[1:4], + c(-0.8229475, 0.1918119, -0.7627081, 0.9955730), + tolerance = 0.0001 + ) + # ref_period + dates <- dates1 + ref_period = list(2011, 2014) + # handle_infinity + expect_equal( + any(is.infinite(PeriodStandardization(data = dat1, handle_infinity = T))), + FALSE + ) + # method + expect_equal( + PeriodStandardization(data = dat1, method = 'non-parametric')[,1,1,1], + c(-0.5143875, 0.3492719, -0.7163839, 1.6413758, 0.4580046, -0.6949654), + tolerance = 0.0001 + ) + # distribution + expect_equal( + all(is.na(PeriodStandardization(data = dat1, distribution = 'Gamma'))), + TRUE + ) + expect_equal( + PeriodStandardization(data = dat3, distribution = 'Gamma')[1:5], + c(-1.2059075, 0.3285372, -3.1558450, 1.5034088, 0.5123442) + ) + # na.rm + dat1[1,1,1,1] <- NA + expect_equal( + all(is.na(PeriodStandardization(data = dat1, na.rm = FALSE)[,1,1,1])), + TRUE + ) + expect_equal( + !all(is.na(PeriodStandardization(data = dat1, na.rm = TRUE)[,1,1,1])), + TRUE + ) + expect_equal( + any(is.na(PeriodStandardization(data = dat1, data_cor = datcor1, na.rm = TRUE))), + FALSE + ) + expect_equal( + any(is.na(PeriodStandardization(data = dat1, data_cor = datcor1, na.rm = FALSE))), + TRUE + ) + # ncores +}) diff --git a/tests/testthat/test-PeriodVariance.R b/tests/testthat/test-PeriodVariance.R new file mode 100644 index 0000000000000000000000000000000000000000..e1de0327cd029d4283e443a5e31780939c50b074 --- /dev/null +++ b/tests/testthat/test-PeriodVariance.R @@ -0,0 +1,128 @@ +library(CSTools) + +############################################## +test_that("1. Sanity Checks", { + # data + expect_error( + PeriodVariance('x'), + "Parameter 'data' must be numeric." + ) + expect_equal( + PeriodVariance(array(1:2, c(x = 2)), time_dim = 'x'), + 0.5 + ) + expect_error( + PeriodVariance(data = NULL), + "Parameter 'data' cannot be NULL." + ) + # time_dim + expect_error( + PeriodVariance(array(1:10), time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + PeriodVariance(array(1:10, dim = c(time = 10)), time_dim = 'ftime'), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + expect_error( + PeriodVariance(1, dates = '2000-01-01', end = 3, start = 4), + "Parameter 'start' and 'end' must be lists indicating the day and the month of the period start and end." + ) + expect_equal( + PeriodVariance(array(1:10, c(time = 10))), + 9.166667, + tolerance = 0.001 + ) + data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) + expect_equal( + PeriodVariance(data), + array(rep(4, 8), + c(sdate = 2, lon = 4)) + ) + # Test dates warning + expect_warning( + PeriodVariance(array(1:10, c(time = 10)), + dates = seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("10-05-2000", format = "%d-%m-%Y"), by = 'day'), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' must have named dimensions if 'start' and 'end' ", + "are not NULL. All data will be used.") + ) + # start and end when dates is not provided + expect_warning( + PeriodVariance(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) +}) + +############################################## + +test_that("2. Seasonal", { + exp <- NULL + exp$data <- array(1:(1 * 3 * 214 * 2), + c(memb = 1, sdate = 3, time = 214, lon = 2)) + exp$dims <- dim(exp$data) + exp$attrs$Dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), + as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2001", format = "%d-%m-%Y"), + as.Date("31-10-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-04-2002", format = "%d-%m-%Y"), + as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day')) + dim(exp$attrs$Dates) <- c(time = 214, sdate = 3) + class(exp) <- 's2dv_cube' + output <- exp + output$data <- array(c(var(exp$data[1,1,21:82,1]), var(exp$data[1,2,21:82,1]), + var(exp$data[1,3,21:82,1]), var(exp$data[1,1,21:82,2]), + var(exp$data[1,2,21:82,2]), var(exp$data[1,3,21:82,2])), + c(memb = 1, sdate = 3, lon = 2)) + expect_equal( + CST_PeriodVariance(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) +}) + +############################################## +test_that("3. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodVariance(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) + diff --git a/tests/testthat/test-QThreshold.R b/tests/testthat/test-QThreshold.R index 41cc3e5312d1e7d56d698bd0c1f6432772e06608..4d7fc592e50e69d058c65573615f4ec5a29a67cc 100644 --- a/tests/testthat/test-QThreshold.R +++ b/tests/testthat/test-QThreshold.R @@ -1,6 +1,21 @@ -context("CSIndicators::QThreshold tests") -test_that("Sanity checks", { +library(CSTools) + +# dat1 +threshold <- 26 +dat1 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, time = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates1 <- dates0 +dim(dates1) <- c(sdate = 3, time = 214) + +############################################## +test_that("1. Sanity checks", { expect_error( QThreshold(NULL), "Parameter 'data' cannot be NULL." @@ -41,23 +56,23 @@ test_that("Sanity checks", { dim(QThreshold(data, threshold)), c(sdate = 20, x = 2) ) - data <- array(1:40, c(x = 2, ftime = 20)) + data <- array(1:40, c(x = 2, time = 20)) expect_error( QThreshold(data, threshold), "Could not find dimension 'sdate' in 1th object provided in 'data'." ) expect_equal( - dim(QThreshold(data, threshold, sdate_dim = 'ftime')), - c(ftime = 20, x = 2) + dim(QThreshold(data, threshold, sdate_dim = 'time')), + c(time = 20, x = 2) ) - dim(threshold) <- c(member = 1, ftime = 1) + dim(threshold) <- c(member = 1, time = 1) expect_equal( - dim(QThreshold(data, threshold, sdate_dim = 'ftime')), - c(ftime = 20, x = 2) + dim(QThreshold(data, threshold, sdate_dim = 'time')), + c(time = 20, x = 2) ) expect_equal( - dim(QThreshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), - c(ftime = 20, x = 2) + dim(QThreshold(data, threshold, memb_dim = 'x', sdate_dim = 'time')), + c(time = 20, x = 2) ) expect_error( QThreshold(data, threshold, sdate_dim = 'x', ncores = 'Z'), @@ -89,29 +104,46 @@ test_that("Sanity checks", { # test different common dimensions - exp <- array(1:61, dim = c(ftime = 61, sdate = 3)) - threshold <- array(1:61, dim = c(ftime = 61)) + exp <- array(1:61, dim = c(time = 61, sdate = 3)) + threshold <- array(1:61, dim = c(time = 61)) Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-06-2002", format = "%d-%m-%Y"), by = 'day')) - dim(Dates) <- c(ftime = 61, sdate = 3, syear = 1) + dim(Dates) <- c(time = 61, sdate = 3, syear = 1) res <- QThreshold(data = exp, dates = Dates, start = list(21, 4), end = list(21, 6), threshold = threshold, - time_dim = 'ftime', sdate_dim = 'sdate') + time_dim = 'time', sdate_dim = 'sdate') expect_equal( dim(res), - c(sdate = 3, ftime = 52) + c(sdate = 3, time = 52) + ) + # test start and end + expect_warning( + QThreshold(dat1, threshold = 26, dates = dates0, start = list(21, 4), + end = list(21, 6)), + paste0("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(QThreshold(dat1, threshold = 26, dates = dates1, start = list(21, 4), + end = list(21, 6))), + c(sdate = 3, member = 5, time = 52, lon = 2) + ) + # start and end when dates is not provided + expect_warning( + QThreshold(array(1:61, dim = c(time = 61, sdate = 3)), threshold = 25, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") ) - }) ############################################## -library(CSTools) -test_that("Seasonal forecasts", { +test_that("2. Seasonal forecasts", { obs <- CSTools::lonlat_temp$obs$data - 248 obs_percentile <- QThreshold(obs, threshold = 35) expect_equal( @@ -132,7 +164,7 @@ test_that("Seasonal forecasts", { obs1_percentile <- QThreshold(obs1, threshold = 35), "'x' must have 1 or more non-missing values" ) - obs2 <- obs[,,,2,,] # one ftime + obs2 <- obs[,,,2,,] # one time obs2_percentile <- QThreshold(obs2, threshold = 35) expect_equal( dim(obs2), @@ -143,3 +175,5 @@ test_that("Seasonal forecasts", { c(0.6, 0.4, 0.6, 0.6, 0.4, 0.4) ) }) + +############################################## diff --git a/tests/testthat/test-SelectPeriod.R b/tests/testthat/test-SelectPeriod.R index 1c264c2b2ef5f88a85fb2ddac70f77908efd9ff9..93fc6eb52dd94714db6be8dc3fc67dcbb505d3aa 100644 --- a/tests/testthat/test-SelectPeriod.R +++ b/tests/testthat/test-SelectPeriod.R @@ -1,4 +1,4 @@ -context("CSIndicators::SelectPeriodOnData and SelectPeriodOnDates tests") +############################################## library(s2dv) @@ -42,19 +42,19 @@ test_that("2. Output checks", { ) # test different common dimensions - exp <- array(1:61, dim = c(ftime = 61)) + exp <- array(1:61, dim = c(time = 61)) Dates <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), as.Date("30-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2001", format = "%d-%m-%Y"), as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-05-2002", format = "%d-%m-%Y"), as.Date("30-06-2002", format = "%d-%m-%Y"), by = 'day')) - dim(Dates) <- c(ftime = 61, sdate = 3) + dim(Dates) <- c(time = 61, sdate = 3) res <- SelectPeriodOnData(data = exp, dates = Dates, start = list(21, 4), end = list(21, 6)) expect_equal( dim(res), - c(ftime = 52) + c(time = 52) ) }) @@ -65,7 +65,7 @@ test_that("3. Decadal", { # decadal: 1 sdate several consequtive years: dates <- seq(as.Date("01-01-2000", "%d-%m-%Y", tz = 'UTC'), as.Date("31-12-2005","%d-%m-%Y", tz = 'UTC'), "day") - dim(dates) <- c(ftime = length(dates)) + dim(dates) <- c(time = length(dates)) # No dims -> test .position output <- c( seq(as.Date("2000-02-01", "%Y-%m-%d"), as.Date("2000-02-10", "%Y-%m-%d"), 'day'), @@ -74,20 +74,20 @@ test_that("3. Decadal", { seq(as.Date("2003-02-01", "%Y-%m-%d"), as.Date("2003-02-10", "%Y-%m-%d"), 'day'), seq(as.Date("2004-02-01", "%Y-%m-%d"), as.Date("2004-02-10", "%Y-%m-%d"), 'day'), seq(as.Date("2005-02-01", "%Y-%m-%d"), as.Date("2005-02-10", "%Y-%m-%d"), 'day')) - dim(output) <- c(ftime = 60) + dim(output) <- c(time = 60) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output ) data <- array(1:(length(dates)*3), - c(memb = 1, ftime = length(dates), lon = 3)) + c(memb = 1, time = length(dates), lon = 3)) expect_equal( SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2)), array(c(c(32:41, 398:407, 763:772, 1128:1137, 1493:1502, 1859:1868), c(32:41, 398:407, 763:772, 1128:1137, 1493:1502, 1859:1868) + 2192, c(32:41, 398:407, 763:772, 1128:1137, 1493:1502, 1859:1868) + 2 * 2192), - c(memb = 1, ftime = 60, lon = 3)) + c(memb = 1, time = 60, lon = 3)) ) output2 <- c( @@ -97,7 +97,7 @@ test_that("3. Decadal", { seq(as.Date("2003-02-01", "%Y-%m-%d"), as.Date("2003-04-10", "%Y-%m-%d"), 'day'), seq(as.Date("2004-02-01", "%Y-%m-%d"), as.Date("2004-04-10", "%Y-%m-%d"), 'day'), seq(as.Date("2005-02-01", "%Y-%m-%d"), as.Date("2005-04-10", "%Y-%m-%d"), 'day')) - dim(output2) <- c(ftime = 416) + dim(output2) <- c(time = 416) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), output2 @@ -108,11 +108,11 @@ test_that("3. Decadal", { array(c(c(32:101, 398:466, 763:831, 1128:1196, 1493:1562, 1859:1927), c(32:101, 398:466, 763:831, 1128:1196, 1493:1562, 1859:1927) + 2192, c(32:101, 398:466, 763:831, 1128:1196, 1493:1562, 1859:1927) + 2 * 2192), - c(memb = 1, ftime = 416, lon = 3)) + c(memb = 1, time = 416, lon = 3)) ) # 1 dim -> test Apply - dim(dates) <- c(ftime = length(dates)) + dim(dates) <- c(time = length(dates)) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output @@ -125,50 +125,50 @@ test_that("3. Decadal", { # decadal: 5 sdates several consequtive years dates <- rep(seq(as.Date("01-01-2000", "%d-%m-%Y", tz = 'UTC'), as.Date("31-12-2005","%d-%m-%Y", tz = 'UTC'), "day"), 5) - dim(dates) <- c(ftime = 2192, sdate = 5) + dim(dates) <- c(time = 2192, sdate = 5) output3 <- rep(output, 5) - dim(output3) <- c(ftime = 60, sdate = 5) + dim(output3) <- c(time = 60, sdate = 5) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output3) data <- array(1:(length(dates)*3), - c(memb = 1, sdate = 5, ftime = length(dates)/5, lon = 3)) + c(memb = 1, sdate = 5, time = length(dates)/5, lon = 3)) expect_equal( #To be extended for all sdate dimensions: SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2))[1,1, ,1], c(1:10 * 5 + 151, 1:10 * 5 + 1981, 1:10 * 5 + 3806, 1:10 * 5 + 5631, 1:10 * 5 + 7456, 1:10 * 5 + 9286) ) output4 <- rep(output2, 5) - dim(output4) <- c(ftime = 416, sdate = 5) + dim(output4) <- c(time = 416, sdate = 5) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), output4 ) - expect_equal( #To be extended for all ftime dimensions: + expect_equal( #To be extended for all time dimensions: SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4))[1, ,1,1], 156:160 ) - # Multiple dims: sdate, fyear, ftime + # Multiple dims: sdate, fyear, time dates <- CSTools::SplitDim(dates, indices = dates[,1], - split_dim = 'ftime', freq = 'year') + split_dim = 'time', freq = 'year') dates <- as.POSIXct(dates * 24 * 3600, origin = '1970-01-01', tz = 'UTC') - output5 <- CSTools::SplitDim(output3, indices = output3[,1], split_dim = 'ftime' , freq = 'year') + output5 <- CSTools::SplitDim(output3, indices = output3[,1], split_dim = 'time' , freq = 'year') output5 <- as.POSIXct(output5 * 24 * 3600, origin = '1970-01-01', tz = 'UTC') expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), output5 ) data <- array(1:(366*6*5*3), - c(memb = 1, sdate = 5, year = 6, ftime = 366, lon = 3)) + c(memb = 1, sdate = 5, year = 6, time = 366, lon = 3)) expect_equal( SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2)), - InsertDim(Reorder(data[, , , 32:41, ], c('sdate', 'year', 'ftime', 'lon')), + InsertDim(Reorder(data[, , , 32:41, ], c('sdate', 'year', 'time', 'lon')), len = 1, pos = 1, name = 'memb') ) - output6 <- CSTools::SplitDim(output4, indices = output4[,1], split_dim = 'ftime' , freq = 'year') + output6 <- CSTools::SplitDim(output4, indices = output4[,1], split_dim = 'time' , freq = 'year') output6 <- as.POSIXct(output6 * 24 * 3600, origin = '1970-01-01', tz = 'UTC') expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), @@ -177,13 +177,13 @@ test_that("3. Decadal", { # expect_equal( # to be fixed: # SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4)), # (931:935), outer(seq(931, 3001, 30), 0:4, '+') - # InsertDim(Reorder(data[,,,32:41,], c('ftime', 'sdate', 'year', 'lon')), + # InsertDim(Reorder(data[,,,32:41,], c('time', 'sdate', 'year', 'lon')), # len = 1, pos = 2, name = 'memb')) }) ############################################## test_that("4. Seasonal", { - # 1 start month, select the required 'ftime' of each 'sdate' in-between the entire timeseries + # 1 start month, select the required 'time' of each 'sdate' in-between the entire timeseries dates <- c(seq(as.Date("01-04-2000", format = "%d-%m-%Y"), as.Date("31-10-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2001", format = "%d-%m-%Y"), @@ -192,7 +192,7 @@ test_that("4. Seasonal", { as.Date("31-10-2002", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-04-2003", format = "%d-%m-%Y"), as.Date("31-10-2003", format = "%d-%m-%Y"), by = 'day')) - dim(dates) <- c(ftime = 214, sdate = 4) + dim(dates) <- c(time = 214, sdate = 4) output <- c(seq(as.Date("21-04-2000", format = "%d-%m-%Y"), as.Date("21-06-2000", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("21-04-2001", format = "%d-%m-%Y"), @@ -201,7 +201,7 @@ test_that("4. Seasonal", { as.Date("21-06-2002", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("21-04-2003", format = "%d-%m-%Y"), as.Date("21-06-2003", format = "%d-%m-%Y"), by = 'day')) - dim(output) <- c(ftime = 62, sdate = 4) + dim(output) <- c(time = 62, sdate = 4) expect_equal( SelectPeriodOnDates(dates, start = list(21, 4), end = list(21, 6)), output @@ -209,8 +209,8 @@ test_that("4. Seasonal", { # following the above case, and select the data data <- array(1:(5 * 4 * 214 * 2), - c(memb = 5, sdate = 4, ftime = 214, lon = 2)) - dim(dates) <- c(ftime = 214, sdate = 4) + c(memb = 5, sdate = 4, time = 214, lon = 2)) + dim(dates) <- c(time = 214, sdate = 4) expect_equal( SelectPeriodOnData(data, dates, start = list(21, 4), end = list(21, 6))[1,1, ,1], @@ -220,7 +220,7 @@ test_that("4. Seasonal", { # when selecting the days across two years dates <- seq(as.Date("2000-01-01", "%Y-%m-%d"), as.Date("2003-12-31", "%Y-%m-%d"), 'day') - dim(dates) <- c(ftime = 1461) + dim(dates) <- c(time = 1461) output1 <- c(seq(as.Date("01-01-2000", format = "%d-%m-%Y"), as.Date("31-01-2000", format = "%d-%m-%Y"), by = 'day'), @@ -232,7 +232,7 @@ test_that("4. Seasonal", { as.Date("31-01-2003", format = "%d-%m-%Y"), by = 'day'), seq(as.Date("01-12-2003", format = "%d-%m-%Y"), as.Date("31-12-2003", format = "%d-%m-%Y"), by = 'day')) - dim(output1) <- c(ftime = 31 * 8) + dim(output1) <- c(time = 31 * 8) expect_equal( SelectPeriodOnDates(dates, start = list(1, 12), end = list(31, 1)), @@ -241,12 +241,12 @@ test_that("4. Seasonal", { # following the above case, and select the data data1 <- array(1:(length(dates) * 2), - c(memb = 1, ftime = length(dates), lon = 2)) + c(memb = 1, time = length(dates), lon = 2)) expect_equal( SelectPeriodOnData(data1, dates, start = list(1, 12), end = list(31, 1)), array(c(c(1:31, 336:397, 701:762, 1066:1127, 1431:1461), c(1:31, 336:397, 701:762, 1066:1127, 1431:1461) + 1461), - c(memb = 1, ftime = 31 * 8, lon = 2)) + c(memb = 1, time = 31 * 8, lon = 2)) ) }) diff --git a/tests/testthat/test-Threshold.R b/tests/testthat/test-Threshold.R index 24ca6010fd895b35b824f5c83fba030280b3d45f..677c21eebfb0dbcca5bd14400b7d1dd07d4fb463 100644 --- a/tests/testthat/test-Threshold.R +++ b/tests/testthat/test-Threshold.R @@ -1,6 +1,21 @@ -context("CSIndicators::Threshold tests") -test_that("Sanity checks", { +library(CSTools) + +# dat1 +threshold <- 0.9 +dat1 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, time = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates1 <- dates0 +dim(dates1) <- c(sdate = 3, time = 214) + +############################################## +test_that("1. Sanity checks", { expect_error( Threshold(NULL), "Parameter 'data' cannot be NULL." @@ -42,28 +57,49 @@ test_that("Sanity checks", { Threshold(data, threshold, memb_dim = NULL), array(c(2.8, 4.6, 3.8, 5.6), c(probs = 2, lat = 2)) ) - data <- array(1:40, c(x = 2, ftime = 20)) + data <- array(1:40, c(x = 2, time = 20)) expect_error( Threshold(data, threshold), "Could not find dimension 'sdate' in 1th object provided in 'data'." ) expect_equal( - dim(Threshold(data, threshold, sdate_dim = 'ftime', memb_dim = NULL)), + dim(Threshold(data, threshold, sdate_dim = 'time', memb_dim = NULL)), c(probs = 2, x = 2) ) # threshold with dimensions ? - dim(threshold) <- c(member = 2, ftime = 1) + dim(threshold) <- c(member = 2, time = 1) expect_equal( - dim(Threshold(data, threshold, sdate_dim = 'ftime', memb_dim = NULL)), + dim(Threshold(data, threshold, sdate_dim = 'time', memb_dim = NULL)), c(probs = 2, x = 2) ) expect_equal( - dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), + dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'time')), c(probs = 2) ) + # test start and end + expect_warning( + Threshold(dat1, threshold = 0.9, dates = dates0, start = list(21, 4), + end = list(21, 6)), + paste0("Parameter 'dates' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(Threshold(dat1, threshold = 0.8, dates = dates1, start = list(21, 4), + end = list(21, 6))), + c(time = 52, lon = 2) + ) + # start and end when dates is not provided + expect_warning( + Threshold(array(1:366, dim = c(time = 61, sdate = 3, member = 2)), + threshold = 0.8, start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) -test_that("Seasonal forecasts", { +############################################## + +test_that("2. Seasonal forecasts", { exp <- CSTools::lonlat_temp$exp$data thresholdP <- Threshold(exp, threshold = 0.9) expect_equal( diff --git a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R index d2155298df51c082450d75c7d449293020ff3c07..e65ec1e8523a3be3317378d895dc2643465d8719 100644 --- a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R @@ -1,40 +1,40 @@ -context("CSIndicators::TotalSpellTimeExceedingThreshold tests") +############################################## # dat1 dat <- array(1:20, dim = c(2, 10)) thres <- 10 dat1 <- array(1:20, dim = c(time = 2, lat = 10)) thres1 <- array(1:2, dim = c(time = 2)) -dat1_2 <- array(1:40, c(x = 2, ftime = 20)) -threshold1_2 <- array(rep(10, 20), dim = c(member = 1, ftime = 20)) +dat1_2 <- array(1:40, c(x = 2, time = 20)) +threshold1_2 <- array(rep(10, 20), dim = c(member = 1, time = 20)) # dat2 -dat2_1 <- array(1:40, c(x = 2, ftime = 20)) -thres2_1 <- array(10, dim = c(member = 1, ftime = 1)) -dat2_3 <- array(1:20, c(ftime = 5, sdate = 2, lat = 2)) -thres2_3 <- array(1:5, c(ftime = 5)) -dat2_4 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat2_1 <- array(1:40, c(x = 2, time = 20)) +thres2_1 <- array(10, dim = c(member = 1, time = 1)) +dat2_3 <- array(1:20, c(time = 5, sdate = 2, lat = 2)) +thres2_3 <- array(1:5, c(time = 5)) +dat2_4 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) thres2_4 <- array(1:2, c(lat = 2)) # dat3 -dat3_1 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) -dat3_2 <- array(1:40, c(x = 2, ftime = 20)) +dat3_1 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) +dat3_2 <- array(1:40, c(x = 2, time = 20)) # dat4 set.seed(1) -dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat4 <- array(rnorm(60, 23), c(time = 5, fyear = 3, sdate = 2, lat = 2)) set.seed(1) -thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +thres4_1 <- array(rnorm(20, 20), c(time = 5, sdate = 2, lat = 2)) set.seed(2) -thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +thres4_2 <- array(rnorm(20, 25), c(time = 5, sdate = 2, lat = 2)) set.seed(1) -thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +thres4_3 <- array(rnorm(20, 20), c(time = 5, sdate = 2)) set.seed(2) -thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +thres4_4 <- array(rnorm(20, 25), c(time = 5, sdate = 2)) set.seed(1) -thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +thres4_5 <- array(rnorm(5, 20), c(time = 5)) set.seed(2) -thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +thres4_6 <- array(rnorm(5, 25), c(time = 5)) set.seed(1) thres4_7 <- rnorm(5, 20) set.seed(2) @@ -142,6 +142,13 @@ test_that("1. Sanity checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + TotalSpellTimeExceedingThreshold(array(1:10, c(time = 10)), threshold = 5, spell = 2, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ########################################################################### @@ -165,7 +172,7 @@ test_that("2. Output checks", { ) expect_equal( TotalSpellTimeExceedingThreshold(dat2_1, thres2_1, spell = 2, time_dim = 'x'), - array(c(rep(0,5), rep(2,15)), c(ftime = 20)) + array(c(rep(0,5), rep(2,15)), c(time = 20)) ) # dimensions expect_equal( @@ -177,7 +184,7 @@ test_that("2. Output checks", { c(sdate = 2, lat = 2) ) expect_equal( - dim(TotalSpellTimeExceedingThreshold(dat2_4, thres2_4, spell = 3, time_dim = 'ftime')), + dim(TotalSpellTimeExceedingThreshold(dat2_4, thres2_4, spell = 3, time_dim = 'time')), c(fyear = 3, sdate = 2, lat = 2) ) }) @@ -199,11 +206,11 @@ test_that("3. Output checks", { array(c(rep(0,11),3), dim = c(fyear = 3, sdate = 2, lat = 2)) ) expect_equal( - TotalSpellTimeExceedingThreshold(dat3_2, c(46, 35), spell = 3, op = c("<", ">"), time_dim = 'ftime'), + TotalSpellTimeExceedingThreshold(dat3_2, c(46, 35), spell = 3, op = c("<", ">"), time_dim = 'time'), array(c(0, 3), c(x = 2)) ) expect_equal( - TotalSpellTimeExceedingThreshold(dat3_2, c(7,11), spell = 3, op = c('>=', '<='), time_dim = 'ftime'), + TotalSpellTimeExceedingThreshold(dat3_2, c(7,11), spell = 3, op = c('>=', '<='), time_dim = 'time'), array(c(3, 0), c(x = 2)) ) expect_equal( @@ -226,40 +233,84 @@ test_that("4. Output checks", { c(3, 5, 0) ) expect_equal( - as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), spell = 4, c(">", "<="), time_dim = 'ftime'))[1:5], + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), spell = 4, c(">", "<="), time_dim = 'time'))[1:5], c(0, 5, 0, 5, 5) ) expect_equal( - as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), spell = 3, op = c("<", ">="), time_dim = 'ftime'))[1:5], + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), spell = 3, op = c("<", ">="), time_dim = 'time'))[1:5], c(3, 5, 0, 5, 3) ) expect_equal( - as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), spell = 3, op = c('>=', '<='), time_dim = 'ftime'))[4:10], + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), spell = 3, op = c('>=', '<='), time_dim = 'time'))[4:10], c(5, 3, 5, 4, 3, 5, 5) ) }) -########################################################################### +################################################################## test_that("5. Seasonal Forecasts", { exp <- CSTools::lonlat_temp$exp exp$data <- exp$data[1,1:3,1:3,,,] - res <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 260, spell = 2) + res <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 260, spell = 2, time_dim = 'ftime') expect_equal( res$data[,,1,1], array(c(3,3,3,3,3,3,3,3,3), c(member = 3, sdate = 3)) ) # compare with percentile thresholdP <- Threshold(exp$data, threshold = 0.9) - WSDI <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP, spell = 2) + WSDI <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP, spell = 2, time_dim = 'ftime') expect_equal( WSDI$data[3,3,3,], c(rep(0, 6), rep(2, 2), 0, 2, 0, 2, rep(0, 29), 2, rep(0, 11)) ) thresholdP1 <- thresholdP[1,,] - WSDI1 <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP1, spell = 2) + WSDI1 <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = thresholdP1, spell = 2, time_dim = 'ftime') expect_equal( WSDI1$data[3,3,3,], c(rep(0, 53))) }) + +################################################################## + +test_that("6. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMean(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) \ No newline at end of file diff --git a/tests/testthat/test-TotalTimeExceedingThreshold.R b/tests/testthat/test-TotalTimeExceedingThreshold.R index 68c6d777f2dddb896380cb902488451680862cba..cba27ae03b2ddb5be192a701453f7a8e2cf6b336 100644 --- a/tests/testthat/test-TotalTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalTimeExceedingThreshold.R @@ -1,46 +1,46 @@ -context("CSIndicators::TotalTimeExceedingThreshold tests") +############################################## # dat1 dat <- array(1:20, dim = c(2, 10)) thres <- 10 dat1 <- array(1:20, dim = c(time = 2, lat = 10)) thres1 <- array(1:2, dim = c(time = 2)) -dat1_2 <- array(1:40, c(x = 2, ftime = 20)) -threshold1_2 <- array(rep(10, 20), dim = c(member = 1, ftime = 20)) +dat1_2 <- array(1:40, c(x = 2, time = 20)) +threshold1_2 <- array(rep(10, 20), dim = c(member = 1, time = 20)) # dat2 -dat2_1 <- array(1:40, c(x = 2, ftime = 20)) -thres2_1 <- array(10, dim = c(member = 1, ftime = 1)) -dat2_3 <- array(1:20, c(ftime = 5, sdate = 2, lat = 2)) -thres2_3 <- array(1:5, c(ftime = 5)) -dat2_4 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat2_1 <- array(1:40, c(x = 2, time = 20)) +thres2_1 <- array(10, dim = c(member = 1, time = 1)) +dat2_3 <- array(1:20, c(time = 5, sdate = 2, lat = 2)) +thres2_3 <- array(1:5, c(time = 5)) +dat2_4 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) thres2_4 <- array(1:2, c(lat = 2)) # dat3 -dat3_1 <- array(1:60, c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) -dat3_2 <- array(1:40, c(x = 2, ftime = 20)) +dat3_1 <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) +dat3_2 <- array(1:40, c(x = 2, time = 20)) # dat4 set.seed(1) -dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +dat4 <- array(rnorm(60, 23), c(time = 5, fyear = 3, sdate = 2, lat = 2)) set.seed(1) -thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +thres4_1 <- array(rnorm(20, 20), c(time = 5, sdate = 2, lat = 2)) set.seed(2) -thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +thres4_2 <- array(rnorm(20, 25), c(time = 5, sdate = 2, lat = 2)) set.seed(1) -thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +thres4_3 <- array(rnorm(20, 20), c(time = 5, sdate = 2)) set.seed(2) -thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +thres4_4 <- array(rnorm(20, 25), c(time = 5, sdate = 2)) set.seed(1) -thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +thres4_5 <- array(rnorm(5, 20), c(time = 5)) set.seed(2) -thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +thres4_6 <- array(rnorm(5, 25), c(time = 5)) set.seed(1) thres4_7 <- rnorm(5, 20) set.seed(2) thres4_8 <- rnorm(5, 25) -########################################################################### +############################################################# test_that("1. Sanity checks", { # data @@ -134,10 +134,17 @@ test_that("1. Sanity checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + TotalTimeExceedingThreshold(array(1:10, c(time = 10)), threshold = 5, + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) -########################################################################### +####################################################### test_that("2. Output checks", { expect_equal( @@ -158,7 +165,7 @@ test_that("2. Output checks", { ) expect_equal( TotalTimeExceedingThreshold(dat2_1, thres2_1, time_dim = 'x'), - array(c(rep(0,5), rep(2,15)), c(ftime = 20)) + array(c(rep(0,5), rep(2,15)), c(time = 20)) ) # dimensions expect_equal( @@ -170,7 +177,7 @@ test_that("2. Output checks", { c(sdate = 2, lat = 2) ) expect_equal( - dim(TotalTimeExceedingThreshold(dat2_4, thres2_4, time_dim = 'ftime')), + dim(TotalTimeExceedingThreshold(dat2_4, thres2_4, time_dim = 'time')), c(fyear = 3, sdate = 2, lat = 2) ) }) @@ -191,11 +198,11 @@ test_that("3. Output checks", { array(c(rep(0, 10), 1, 3), dim = c(fyear = 3, sdate = 2, lat = 2)) ) expect_equal( - TotalTimeExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'ftime'), + TotalTimeExceedingThreshold(dat3_2, c(46, 35), op = c("<", ">"), time_dim = 'time'), array(c(2, 3), c(x = 2)) ) expect_equal( - TotalTimeExceedingThreshold(dat3_2, c(7, 11), op = c('>=', '<='), time_dim = 'ftime'), + TotalTimeExceedingThreshold(dat3_2, c(7, 11), op = c('>=', '<='), time_dim = 'time'), array(c(3, 2), c(x = 2)) ) expect_equal( @@ -216,39 +223,83 @@ test_that("4. Output checks", { c(4, 5, 3) ) expect_equal( - as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'ftime'))[1:5], + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'time'))[1:5], c(4, 5, 3, 5, 5) ) expect_equal( - as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'ftime'))[1:5], + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_6, thres4_5), op = c("<", ">="), time_dim = 'time'))[1:5], c(4, 5, 3, 5, 4) ) expect_equal( - as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'ftime'))[4:10], + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'time'))[4:10], c(5, 4, 5, 4, 4, 5, 5) ) }) ########################################################################### -test_that("Seasonal forecasts", { +test_that("5. Seasonal forecasts", { # compare with scalar fixed threshold exp <- CSTools::lonlat_temp$exp obs <- CSTools::lonlat_temp$obs exp$data <- exp$data[1, 1:3, , , , ] - 247 - SU35_NoP <- CST_TotalTimeExceedingThreshold(exp, threshold = 35)$data + SU35_NoP <- CST_TotalTimeExceedingThreshold(exp, threshold = 35, time_dim = 'ftime')$data expect_equal( SU35_NoP[1, , 15, 3], c(0, 1, 1, 1, 0, 0) ) # convert to percentile exp_percentile <- AbsToProbs(exp$data) - obs_percentile <- drop(QThreshold(obs$data, threshold = 35)) + obs_percentile <- drop(QThreshold(obs$data, threshold = 35, time_dim = 'ftime')) data <- exp data$data <- exp_percentile - SU35_P <- CST_TotalTimeExceedingThreshold(data, threshold = obs_percentile)$data + SU35_P <- CST_TotalTimeExceedingThreshold(data, threshold = obs_percentile, time_dim = 'ftime')$data expect_equal( SU35_P[2, , 5, 5], c(3, 3, 3, 3, 3, 3) ) }) + +################################################################## + +test_that("6. Subset Dates and check time_bounds", { + exp <- CSTools::lonlat_prec + res <- CST_PeriodMean(data = CSTools::lonlat_prec, time_dim = 'ftime', + start = list(10, 03), end = list(20, 03)) + # Check dims + expect_equal( + dim(res$data), + res$dims + ) + # Check Dates + expect_equal( + dim(res$data)['sdate'], + dim(res$attrs$Dates) + ) + # Check time_bounds + expect_equal( + res$attrs$Dates, + res$attrs$time_bounds$start + ) + expect_equal( + dim(res$attrs$time_bounds$start), + dim(res$attrs$time_bounds$end) + ) + # Check 'sdates' + expect_equal( + all(lubridate::month(res$attrs$time_bounds$start) == 3), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$start) == 10), + TRUE + ) + expect_equal( + all(lubridate::month(res$attrs$time_bounds$end) == 03), + TRUE + ) + expect_equal( + all(lubridate::day(res$attrs$time_bounds$end) == 20), + TRUE + ) +}) diff --git a/tests/testthat/test-WindCapacityFactor.R b/tests/testthat/test-WindCapacityFactor.R index 1bf9089e2fd3eef4ee9903f4c136f5fdf22c5906..a2c3fbf0ec1bbd6b0bca78ba3322912edf84a682 100644 --- a/tests/testthat/test-WindCapacityFactor.R +++ b/tests/testthat/test-WindCapacityFactor.R @@ -1,4 +1,4 @@ -context("CSIndicators::WindCapacityFactor tests") +############################################## # dat1 wind <- NULL @@ -12,7 +12,19 @@ wind$attrs <- list(Variable = variable, Datasets = 'synthetic', class(wind) <- 's2dv_cube' WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") -########################################################################### +# dat2 +dat2 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, time = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates2 <- dates0 +dim(dates2) <- c(sdate = 3, time = 214) + +################################################### test_that("1. Input checks", { # Check 's2dv_cube' expect_error( @@ -33,9 +45,16 @@ test_that("1. Input checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + WindCapacityFactor(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) -########################################################################### +#################################################### test_that("2. Output checks", { expect_equal( CST_WindCapacityFactor(wind = wind)$attrs$Variable$varName, @@ -45,5 +64,17 @@ test_that("2. Output checks", { dim(CST_WindCapacityFactor(wind = wind)$data), c(member = 10, lat = 2, lon = 5) ) + # test start and end + expect_warning( + WindCapacityFactor(wind = dat2, IEC_class = "III", dates = dates0, + start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(WindCapacityFactor(wind = dat2, IEC_class = "III", dates = dates2, + start = list(21, 4), end = list(21, 6))), + c(member = 5, sdate = 3, time = 52, lon = 2) + ) }) diff --git a/tests/testthat/test-WindPowerDensity.R b/tests/testthat/test-WindPowerDensity.R index 249c5290cfb43ddf49ba7bacef4747875763de32..e6e981e5e4395acb39624c7f7ce5b63224bb7d42 100644 --- a/tests/testthat/test-WindPowerDensity.R +++ b/tests/testthat/test-WindPowerDensity.R @@ -1,4 +1,4 @@ -context("CSIndicators::WindPowerDensity tests") +########################################################################### # dat1 wind <- NULL @@ -11,6 +11,18 @@ wind$attrs <- list(Variable = variable, Datasets = 'synthetic', when = Sys.time(), Dates = '1990-01-01 00:00:00') class(wind) <- 's2dv_cube' +# dat2 +dat2 <- array(abs(rnorm(5 * 3 * 214 * 2)*50), + c(member = 5, sdate = 3, time = 214, lon = 2)) +dates0 <- c(seq(as.Date("01-05-2000", format = "%d-%m-%Y"), + as.Date("30-11-2000", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2001", format = "%d-%m-%Y"), + as.Date("30-11-2001", format = "%d-%m-%Y"), by = 'day'), + seq(as.Date("01-05-2002", format = "%d-%m-%Y"), + as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) +dates2 <- dates0 +dim(dates2) <- c(sdate = 3, time = 214) + ########################################################################### test_that("1. Input checks", { # Check 's2dv_cube' @@ -32,6 +44,13 @@ test_that("1. Input checks", { paste0("Parameter 'start' and 'end' must be lists indicating the ", "day and the month of the period start and end.") ) + # start and end when dates is not provided + expect_warning( + WindPowerDensity(array(1:10, c(time = 10)), + start = list(05, 02), end = list(05, 09)), + paste0("Parameter 'dates' is NULL and the average of the full data ", + "provided in 'data' is computed.") + ) }) ########################################################################### @@ -44,5 +63,17 @@ test_that("2. Output checks", { dim(CST_WindPowerDensity(wind = wind)$data), c(member = 10, lat = 2, lon = 5) ) + # test start and end + expect_warning( + WindPowerDensity(wind = dat2, dates = dates0, + start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'wind' must have named dimensions if 'start' and ", + "'end' are not NULL. All data will be used.") + ) + expect_equal( + dim(WindPowerDensity(wind = dat2, dates = dates2, + start = list(21, 4), end = list(21, 6))), + c(member = 5, sdate = 3, time = 52, lon = 2) + ) }) diff --git a/vignettes/AgriculturalIndicators.Rmd b/vignettes/AgriculturalIndicators.Rmd index 3c9cf7d23a9b4fd68b8f819638c85f328bd7c761..6345d6c9cf8fc8f8c5693c43a7c4414623aa5f94 100644 --- a/vignettes/AgriculturalIndicators.Rmd +++ b/vignettes/AgriculturalIndicators.Rmd @@ -2,6 +2,8 @@ title: "Agricultural Indicators" author: "Earth Sciences department, Barcelona Supercomputing Center (BSC)" date: "`r Sys.Date()`" +revisor: "Eva Rifà" +revision date: "October 2023" output: rmarkdown::html_vignette vignette: > %\VignetteEngine{knitr::knitr} @@ -58,47 +60,88 @@ library(s2dv) To obtain the precipitation forecast and observation, we load the daily precipitation (**prlr** given in `var`) data sets of ECMWF SEAS5 seasonal forecast and ERA5 reanalysis for the four starting dates 20130401-20160401 (provided in `sdates`) with the entire 7-month forecast time, April-October (214 days in total given in parameter `leadtimemax`). -The pathways of SEAS5 and ERA5 are given in the lists with some **whitecards (inside two dollar signs)** used to replace the variable name and iterative items such as year and month. See details of requirements in Section 4 in vignette [Data retrieval and storage](https://cran.r-project.org/package=CSTools/vignettes/Data_Considerations.html) from CSTools package. +The pathways of SEAS5 and ERA5 are given in the lists with some **whitecards (inside two dollar signs)** used to replace the variable name and iterative items such as year and month. See details of requirements in Section 5 in vignette [Data retrieval and storage](https://cran.r-project.org/package=CSTools/vignettes/Data_Considerations.html) from CSTools package. The spatial domain covers part of Douro Valley of Northern Portugal lon=[352.25, 353], lat=[41, 41.75]. These four values are provided in `lonmin`, `lonmax`, `latmin` and `latmax`. With `grid` set to **r1440x721**, the SEAS5 forecast would be interpolated to the 0.25-degree ERA5 grid by using the **bicubic** method given in `method`. -``` -S5path_prlr <- list(path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_s0-24h/$VAR_NAME$_$START_DATE$.nc') - -path_ERA5prlr_CDS <- list(path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - +```r sdates <- paste0(2013:2016, '04', '01') -c(prlr_exp, prlr_obs) %<-% CST_Load(var = 'prlr', - exp = list(S5path_prlr), - obs = list(path_ERA5prlr_CDS), - sdates = sdates, - lonmax = 353, lonmin = 352.25, - latmax = 41.75, latmin = 41, - storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, - nmember = 3, output = "lonlat", - grid = "r1440x721", method = 'bicubic') +lat_min = 41 +lat_max = 41.75 +lon_min = 352.25 +lon_max = 353 + +S5path_prlr <- paste0("/esarchive/exp/ecmwf/system5c3s/daily_mean/$var$_s0-24h/$var$_$sdate$.nc") +prlr_exp <- CST_Start(dataset = S5path_prlr, + var = "prlr", + member = startR::indices(1:3), + sdate = sdates, + ftime = startR::indices(1:214), + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + member = c('member', 'ensemble'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lat = NULL, + lon = NULL, ftime = 'sdate'), + retrieve = TRUE) + +dates_exp <- prlr_exp$attrs$Dates + +path_ERA5prlr_CDS <- paste0("/esarchive/recon/ecmwf/era5/daily_mean/$var$_f1h-r1440x721cds/$var$_$date$.nc") +prlr_obs <- CST_Start(dataset = path_ERA5prlr_CDS, + var = "prlr", + date = unique(format(dates_exp, '%Y%m')), + ftime = startR::values(dates_exp), + ftime_across = 'date', + ftime_var = 'ftime', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lon = NULL, + lat = NULL, + ftime = 'date'), + retrieve = TRUE) ``` The output contains data and metadata for the experiment and the observations. The elements `prlr_exp$data` and `prlr_obs$data` have dimensions: -``` +```r dim(prlr_exp$data) -#dataset member sdate ftime lat lon -# 1 3 4 214 4 4 +# dataset var member sdate ftime lat lon +# 1 1 3 4 214 4 4 dim(prlr_obs$data) -#dataset member sdate ftime lat lon -# 1 1 4 214 4 4 +# dataset var sdate ftime lat lon +# 1 1 4 214 4 4 ``` To compute **SprR** of forecast and observation, we can run: -``` +```r SprR_exp <- CST_PeriodAccumulation(prlr_exp, start = list(21, 4), end = list(21, 6)) SprR_obs <- CST_PeriodAccumulation(prlr_obs, start = list(21, 4), end = list(21, 6)) ``` @@ -109,41 +152,41 @@ As mentioned, these parameters are optional, the function will take the entire t The dimensions of SprR forecasts and observations are: -``` +```r dim(SprR_exp$data) -#dataset member sdate lat lon -# 1 3 4 4 4 +# dataset var member sdate lat lon +# 1 1 3 4 4 4 dim(SprR_obs$data) -#dataset member sdate lat lon -# 1 1 4 4 4 +# dataset var sdate lat lon +# 1 1 4 4 4 ``` The forecast SprR for the 1st member from 2013-2016 of the 1st grid point in mm are: -``` -SprR_exp$data[1, 1, , 1, 1] * 86400 * 1000 -#[1] 93.23205 230.41904 194.01412 226.52614 +```r +SprR_exp$data[1, 1, 1, , 1, 1] * 86400 * 1000 +# [1] 93.23236 230.41754 194.01401 226.52564 ``` Dry springs will delay vegetative growth and reduce vigour and leaf area total surface. Fungal disease pressure will be lower and therefore there will be less need for protective and / or curative treatments, translating as less costs. Wet springs will promote higher vigour, increase the risk of fungal disease and disrupt vineyard operations as it may prevent machinery from getting in the vineyard due to mud. They are usually associated with higher costs. On the other hand, another moisture-related indicators, **HarvestR**, can be computed by using `PeriodAccumulation` as well, with the defined period as the following lines. -``` +```r HarvestR_exp <- CST_PeriodAccumulation(prlr_exp, start = list(21, 8), end = list(21, 10)) HarvestR_obs <- CST_PeriodAccumulation(prlr_obs, start = list(21, 8), end = list(21, 10)) ``` The forecast HarvestR for the 1st member from 2013-2016 of the 1st grid point in mm are: -``` -HarvestR_exp$data[1, 1, , 1, 1] * 86400 * 1000 -#[1] 52.30026 42.88068 156.87961 32.18579 +```r +HarvestR_exp$data[1, 1, 1, , 1, 1] * 86400 * 1000 +# [1] 52.30058 42.88070 156.87922 32.18567 ``` To compute the 2013-2016 ensemble-mean bias of forecast HarvestR, run -``` +```r fcst <- drop(HarvestR_exp$data) * 86400 * 1000 obs <- drop(HarvestR_obs$data) * 86400 * 1000 @@ -152,7 +195,7 @@ Bias <- MeanDims((fcst - InsertDim(obs, 1, dim(fcst)['member'])), 'member') To plot the map of ensemble-mean bias of HarvestR forecast, run -``` +```r cols <- c('#b2182b', '#d6604d', '#f4a582', '#fddbc7', '#d1e5f0', '#92c5de', '#4393c3', '#2166ac') @@ -178,42 +221,81 @@ For the function `PeriodMean`, we use Growing Season Temperature (**GST**) as an Firstly, we prepare a sample data of daily mean temperature of SEAS5 and ERA5 data sets with the same starting dates, spatial domain, interpolation grid and method by running -``` -S5path <- list(path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_f6h/$VAR_NAME$_$YEAR$$MONTH$01.nc') -ERA5path <- list(path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - -c(tas_exp, tas_obs) %<-% CST_Load(var = 'tas', exp = list(S5path), obs = list(ERA5path), - sdates = sdates, lonmax = 353, lonmin = 352.25, - latmax = 41.75, latmin = 41, - storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, - nmember = 3, output = "lonlat", - grid = "r1440x721", method = 'bicubic') -``` - -The output contains observations `tas_dv$obs$data` and forecast `tas_dv$exp$data`, and their dimensions and summaries are like - -``` +```r +S5path <- paste0("/esarchive/exp/ecmwf/system5c3s/daily_mean/$var$_f6h/$var$_$sdate$.nc") +tas_exp <- CST_Start(dataset = S5path, + var = "tas", + member = startR::indices(1:3), + sdate = sdates, + ftime = startR::indices(1:214), + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + member = c('member', 'ensemble'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lat = NULL, + lon = NULL, ftime = 'sdate'), + retrieve = TRUE) +dates_exp <- tas_exp$attrs$Dates + +ERA5path <- paste0("/esarchive/recon/ecmwf/era5/daily_mean/$var$_f1h-r1440x721cds/$var$_$date$.nc") +tas_obs <- CST_Start(dataset = ERA5path, + var = "tas", + date = unique(format(dates_exp, '%Y%m')), + ftime = startR::values(dates_exp), + ftime_across = 'date', + ftime_var = 'ftime', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lon = NULL, + lat = NULL, + ftime = 'date'), + retrieve = TRUE) +``` + +The output contains observations `tas_obs$data` and forecast `tas_exp$data`, and their dimensions and summaries are like + +```r dim(tas_obs$data) -#dataset member sdate ftime lat lon -# 1 1 4 214 4 4 +# dataset var sdate ftime lat lon +# 1 1 4 214 4 4 dim(tas_exp$data) -#dataset member sdate ftime lat lon -# 1 3 4 214 4 4 +# dataset var member sdate ftime lat lon +# 1 1 3 4 214 4 4 summary(tas_obs$data - 273.15) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 3.63 13.97 17.25 17.29 20.75 30.21 +# 3.627 13.974 17.248 17.294 20.752 30.206 summary(tas_exp$data - 273.15) -# Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.54 11.65 16.56 16.50 21.25 31.41 +# Min. 1st Qu. Median Mean 3rd Qu. Max. +# 0.5363 11.6517 16.5610 16.4961 21.2531 31.4063 ``` To compute the GST for both observation and forecast, run the following lines -``` +```r # change the unit of temperature from °C to K tas_exp$data <- tas_exp$data - 273.15 @@ -230,7 +312,7 @@ Since the period considered for GST is the entire period for starting month of A The summaries and dimensions of the output are as follows: -``` +```r summary(GST_exp$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. # 14.23 15.78 16.50 16.50 17.17 18.70 @@ -240,17 +322,17 @@ summary(GST_obs$data) # 15.34 16.77 17.22 17.29 18.00 18.75 dim(GST_exp$data) -#dataset member sdate lat lon -# 1 3 4 4 4 +# dataset var member sdate lat lon +# 1 1 3 4 4 4 dim(GST_obs$data) -#dataset member sdate lat lon -# 1 1 4 4 4 +# dataset var sdate lat lon +# 1 1 4 4 4 ``` Here, we plot the 2013-2016 mean climatology of ERA5 GST by running -``` +```r # compute ERA5 GST climatology GST_Clim <- MeanDims(drop(GST_obs$data), 'sdate') @@ -288,29 +370,68 @@ Here, we take SU35 as example, therefore the daily temperature maximum of the en Load SEAS5 and ERA5 daily temperature maximum by running -``` -S5path <- list(path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$/$VAR_NAME$/$VAR_NAME$_$YEAR$$MONTH$01.nc') -ERA5path <- list(path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$/$VAR_NAME$-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') - -c(tasmax_exp, tasmax_obs) %<-% CST_Load(var = 'tasmax', exp = list(S5path), - obs = list(ERA5path), sdates = sdates, - lonmax = 353, lonmin = 352.25, - latmax = 41.75, latmin = 41, storefreq = 'daily', - leadtimemin = 1, leadtimemax = 214, nmember = 3, - output = "lonlat", grid = "r1440x721", - method = 'bicubic', nprocs = 1) +```r +S5path <- paste0("/esarchive/exp/ecmwf/system5c3s/daily/$var$/$var$_$sdate$.nc") +tasmax_exp <- CST_Start(dataset = S5path, + var = "tasmax", + member = startR::indices(1:3), + sdate = sdates, + ftime = startR::indices(1:214), + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + member = c('member', 'ensemble'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lat = NULL, + lon = NULL, ftime = 'sdate'), + retrieve = TRUE) +dates_exp <- tasmax_exp$attrs$Dates + +ERA5path <- paste0("/esarchive/recon/ecmwf/era5/daily/$var$-r1440x721cds/$var$_$date$.nc") +tasmax_obs <- CST_Start(dataset = ERA5path, + var = "tasmax", + date = unique(format(dates_exp, '%Y%m')), + ftime = startR::values(dates_exp), + ftime_across = 'date', + ftime_var = 'ftime', + merge_across_dims = TRUE, + split_multiselected_dims = TRUE, + lat = startR::values(list(lat_min, lat_max)), + lat_reorder = startR::Sort(decreasing = TRUE), + lon = startR::values(list(lon_min, lon_max)), + lon_reorder = startR::CircularSort(0, 360), + synonims = list(lon = c('lon', 'longitude'), + lat = c('lat', 'latitude'), + ftime = c('ftime', 'time')), + transform = startR::CDORemapper, + transform_extra_cells = 2, + transform_params = list(grid = "r1440x721", + method = "bicubic"), + transform_vars = c('lat', 'lon'), + return_vars = list(lon = NULL, + lat = NULL, + ftime = 'date'), + retrieve = TRUE) ``` Check the unit of temperature to from °C to K for the comparison with the threshold defined (for example 35°C here). -``` +```r tasmax_exp$data <- tasmax_exp$data - 273.15 tasmax_obs$data <- tasmax_obs$data - 273.15 ``` Computing SU35 for forecast and observation by running -``` +```r threshold <- 35 SU35_exp <- CST_TotalTimeExceedingThreshold(tasmax_exp, threshold = threshold, start = list(1, 4), end = list(31, 10)) @@ -320,40 +441,40 @@ SU35_obs <- CST_TotalTimeExceedingThreshold(tasmax_obs, threshold = threshold, The summaries of SU35 forecasts and observations are given below. -``` +```r summary(SU35_exp$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.00 2.00 5.00 7.12 12.00 26.00 +# 0.000 2.000 5.000 7.135 12.000 26.000 summary(SU35_obs$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.000 0.000 1.000 2.609 5.000 10.000 +# 0.000 0.000 1.000 2.609 5.000 10.000 ``` As shown in the summaries, SEAS5 SU35 forecasts are overestimated by 5 days in terms of mean value. Therefore, `CST_BiasCorrection` is used to bias adjust the SU35 forecasts. -``` +```r res <- CST_BiasCorrection(obs = SU35_obs, exp = SU35_exp) SU35_exp_BC <- drop(res$data) summary(SU35_exp_BC) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# -1.419 0.000 1.613 2.831 4.756 17.768 +# -1.523 0.000 1.613 2.830 4.756 17.768 ``` Since there are negative values after bias adjustment, all negative data is converted to zero. -``` +```r SU35_exp_BC[SU35_exp_BC < 0] <- 0 summary(SU35_exp_BC) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 0.000 0.000 1.613 2.943 4.756 17.768 +# 0.000 0.000 1.613 2.941 4.756 17.768 ``` Plot the bias-adjusted SU35 forecast in 2016 by running -``` +```r SU35_obs_Y2016 <- drop(SU35_obs$data)[4, , ] SU35_exp_Y2016 <- MeanDims(drop(SU35_exp$data)[, 4, , ], 'member') SU35_exp_BC_Y2016 <- MeanDims(SU35_exp_BC[, 4, , ], 'member') @@ -414,34 +535,34 @@ The revised definition of SU35 is to reduce the potential influence induced by t As mentioned, the forecast is translated to its percentile by using the function `ABsToProbs` by running -``` +```r exp_percentile <- AbsToProbs(tasmax_exp$data) S5txP <- aperm(drop(exp_percentile), c(2, 1, 3, 4, 5)) ``` After that, based on 35 of threshold, the percentile corresponding to each observational value can be calculated as follows. -``` +```r obs_percentile <- QThreshold(tasmax_obs$data, threshold = 35) obs_percentile <- drop(obs_percentile) ``` After translating both forecasts and observations into probabilities, the comparison can then be done by running -``` +```r SU35_exp_Percentile <- TotalTimeExceedingThreshold(S5txP, threshold = obs_percentile, time_dim = 'ftime') ``` Compute the same ensemble-mean SU35 **with percentile adjustment** in 2016 by running -``` +```r SU35_exp_per_Y2016 <- MeanDims(SU35_exp_Percentile[4, , , ], 'member') ``` Plot the same map for comparison -``` +```r toptitle <- 'SU35 forecast with percentile adjustment in 2016' PlotEquiMap(SU35_exp_per_Y2016, lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, @@ -468,14 +589,14 @@ The definition of GDD is the summation of daily differences between daily averag *Note: The data is in degrees Celsiusi at this point* -``` +```r GDD_exp <- CST_AccumulationExceedingThreshold(tas_exp, threshold = 10, diff = TRUE) GDD_obs <- CST_AccumulationExceedingThreshold(tas_obs, threshold = 10, diff = TRUE) ``` The summaries of GDD are -``` +```r summary(GDD_exp$data) # Min. 1st Qu. Median Mean 3rd Qu. Max. # 1021 1331 1480 1469 1596 1873 @@ -487,7 +608,7 @@ summary(GDD_obs$data) To compute the correlation coefficient for the period from 2013-2016, run the following lines -``` +```r # reorder the dimension fcst <- Reorder(drop(GDD_exp$data), c(4, 3, 2, 1)) obs <- Reorder(drop(GDD_obs$data), c(3, 2, 1)) @@ -498,7 +619,7 @@ GDD_Corr <- Reorder(EnsCorr, c(2, 1)) To plot the map of correlation coefficient of GDD for the 2013-2016 period. -``` +```r cols <- c("#f7fcf5", "#e5f5e0", "#c7e9c0", "#a1d99b", "#74c476") toptitle <- '2013-2016 correlation coefficient of GDD' PlotEquiMap(GDD_Corr, lon = tas_obs$coords$lon, lat = tas_obs$coords$lat, @@ -522,32 +643,32 @@ One of the critical agricultural indicators related to dry spell is the **Warm S The maximum temperature data used in Section 3. Since the daily maximum temperature needs to compare to its 90th percentile, the function `Threshold` in the `CSIndicators` package is required to compute the percentile of observations used for each day. Here the same period (2013-2016) is considered. -``` -tx_p <- CST_Threshold(tasmax_obs, threshold = 0.9) +```r +tx_p <- CST_Threshold(tasmax_obs, threshold = 0.9, memb_dim = NULL) ``` The output will be the 90th percentile of each day of each grid point derived by using all the years in the data.See the dimension and summary as below. -``` +```r dim(tx_p$data) -#dataset ftime lat lon -# 1 214 4 4 +# dataset var ftime lat lon +# 1 1 214 4 4 summary(tx_p$data) -# Min. 1st Qu. Median Mean 3rd Qu. Max. +# Min. 1st Qu. Median Mean 3rd Qu. Max. # 13.83 22.08 26.08 26.22 30.72 36.72 ``` With the prepared threshold (90th percentile), the WSDI can be computed by running -``` +```r WSDI_exp <- CST_TotalSpellTimeExceedingThreshold(tasmax_exp, threshold = tx_p, spell = 6) WSDI_obs <- CST_TotalSpellTimeExceedingThreshold(tasmax_obs, threshold = tx_p, spell = 6) ``` After checking the summaries, compute the Fair Ranked Probability Skill Score (FRPSS) of WSDI by running the following lines -``` +```r # Reorder the data fcst <- Reorder(drop(WSDI_exp$data), c(4, 3, 2, 1)) obs <- Reorder(drop(WSDI_obs$data), c(3, 2, 1)) @@ -559,7 +680,7 @@ summary(fcst) summary(obs) # Min. 1st Qu. Median Mean 3rd Qu. Max. -# 9.00 19.00 22.50 23.16 26.00 33.00 +# 9.00 19.00 22.50 23.25 26.00 33.00 # compute FRPSS f <- veriApply('FairRpss', fcst = fcst, obs = obs, ensdim = 4, tdim = 3, prob = 1:2/3)$skillscore @@ -568,7 +689,7 @@ WSDI_FRPSS <- Reorder(f, c(2,1)) Plot the map of WSDI FRPSS for the period from 2013-2016 -``` +```r cols <- c("#edf8fb", "#ccece6", "#99d8c9", "#66c2a4") toptitle <- 'SEAS5 WSDI FRPSS (2013-2016)'