diff --git a/.Rbuildignore b/.Rbuildignore index ba637f5203b039844510c72b6723061599defdd5..c0e2736124c33fe6ccadcad4604bb76ac738da0f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -9,3 +9,4 @@ ./.nfs* ^cran-comments\.md$ ./vignettes/*.md +^inst/doc/paper-figure-PlotForecastPDF\.R$ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 4db1f228e5b3890e93423d8c9200cf3617c8b51c..0873a3f93a877059b3067dfeb9874a5364513428 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -3,7 +3,7 @@ stages: build: stage: build script: - - module load R/3.6.1-foss-2015a-bare + - module load R/4.1.2-foss-2015a-bare - R CMD build --resave-data . - R CMD check --as-cran --no-manual --run-donttest CSIndicators_*.tar.gz - R -e 'covr::package_coverage()' diff --git a/DESCRIPTION b/DESCRIPTION index d85555958676c8a89b5215256862c87e1fdc5cb0..7fcf115d0c7fc117938b624e467bb914e7388602 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: CSIndicators Title: Climate Services' Indicators Based on Sub-Seasonal to Decadal Predictions -Version: 0.0.2 +Version: 1.0.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")), @@ -37,7 +37,7 @@ Suggests: markdown, rmarkdown VignetteBuilder: knitr -License: Apache License 2.0 +License: GPL-3 URL: https://earth.bsc.es/gitlab/es/csindicators/ BugReports: https://earth.bsc.es/gitlab/es/csindicators/-/issues Encoding: UTF-8 diff --git a/NEWS.md b/NEWS.md index fa2bb871d026192b20e4a2731df33061c5d83b59..e28aab8829eab58cde5a114901d086598396db80 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,16 @@ +# CSIndicators 1.0.0 (Release date: 2023-04-05) +**Fixes** +- Correct vignettes figures links. + +**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** - 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(). # CSIndicators 0.0.1 (Release date: 2021-05-07) -- This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales. 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) . \ No newline at end of file +- This package is intended for sub-seasonal, seasonal and decadal climate predictions, but its methods are also applicable to other time-scales. 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) . diff --git a/R/AbsToProbs.R b/R/AbsToProbs.R index 708fabdafbec4e9cbf094fb53c586741a48b52f6..e086e6e429e92615bf9300d5d22bffd083ae7bd7 100644 --- a/R/AbsToProbs.R +++ b/R/AbsToProbs.R @@ -38,47 +38,44 @@ #'exp_probs <- CST_AbsToProbs(exp) #'exp$data <- array(rnorm(5 * 3 * 214 * 2), #' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates[[1]] <- 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_AbsToProbs(exp, start = list(21, 4), end = list(21, 6)) -#' +#'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) +#'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', sdate_dim = 'sdate', ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)[sdate_dim])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)[sdate_dim]) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } - probs <- AbsToProbs(data$data, data$Dates[[1]], start, end, - time_dim = time_dim, memb_dim = memb_dim, - sdate_dim = sdate_dim, ncores = ncores) + + probs <- AbsToProbs(data = data$data, dates = data$attrs$Dates, + start = start, end = end, time_dim = time_dim, + memb_dim = memb_dim, sdate_dim = sdate_dim, + ncores = ncores) data$data <- probs if (!is.null(start) && !is.null(end)) { - data$Dates <- SelectPeriodOnDates(dates = data$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } @@ -90,9 +87,11 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #'Distribution Function excluding the corresponding initialization. #' #'@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 An optional parameter containing 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. All common dimensions with 'data' need to +#' have the same length. #'@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 @@ -118,48 +117,76 @@ CST_AbsToProbs <- function(data, start = NULL, end = NULL, #'probabilites in the element \code{data}. #' #'@examples -#'exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, ftime = 9, lat = 2, lon = 2)) +#'exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, +#' ftime = 9, lat = 2, lon = 2)) #'exp_probs <- AbsToProbs(exp) -#'data <- array(rnorm(5 * 2 * 61 * 1), -#' c(member = 5, sdate = 2, ftime = 61, lon = 1)) +#'data <- array(rnorm(5 * 3 * 61 * 1), +#' c(member = 5, sdate = 3, ftime = 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')) -#'exp_probs <- AbsToProbs(exp, start = list(21, 4), end = list(21, 6)) +#'dim(Dates) <- c(ftime = 61, sdate = 3) +#'exp_probs <- AbsToProbs(data, dates = Dates, start = list(21, 4), +#' end = list(21, 6)) #' #'@import multiApply #'@importFrom stats ecdf #'@export -AbsToProbs <- function(data, dates = NULL, start = NULL, end = NULL, time_dim = 'time', - memb_dim = 'member', +AbsToProbs <- function(data, dates = NULL, start = NULL, end = NULL, + time_dim = 'ftime', memb_dim = 'member', sdate_dim = 'sdate', ncores = NULL) { - if (is.null(data)) { - stop("Parameter 'data' cannot be NULL.") - } + # data if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } + data_is_array <- TRUE if (!is.array(data)) { + data_is_array <- FALSE dim(data) <- c(length(data), 1) names(dim(data)) <- c(memb_dim, sdate_dim) if (!is.null(start) && !is.null(end)) { - 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.") + warning("Parameter 'data' doesn't have dimension names and all ", + "data will be used.") + start <- NULL + end <- NULL + } + } + # dates subset + if (!is.null(start) && !is.null(end)) { + if (!all(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(dates)) { + warning("Parameter 'dates' is not provided and all data will be used.") + } else { + if (is.null(dim(dates))) { + warning("Parameter 'dates' doesn't have dimension names and all ", + "data will be used.") + } else { + data <- SelectPeriodOnData(data, dates, start, end, + time_dim = time_dim, ncores = ncores) } - data <- SelectPeriodOnData(data, dates, start, end, - time_dim = time_dim, ncores = ncores) } } - probs <- Apply(list(data), target_dims = c(memb_dim, sdate_dim), fun = .abstoprobs, + probs <- Apply(list(data), target_dims = c(memb_dim, sdate_dim), + fun = .abstoprobs, ncores = ncores)$output1 + if (!data_is_array) { + dim(probs) <- NULL + } else { + pos <- match(names(dim(data)), names(dim(probs))) + probs <- aperm(probs, pos) + } + return(probs) } + .abstoprobs <- function(data) { - if (dim(data)[2] > 1 ) { # Several sdates + if (dim(data)[2] > 1) { # Several sdates qres <- unlist( lapply(1:(dim(data)[1]), function(x) { # dim 1: member lapply(1:(dim(data)[2]), function(y) { # dim 2: sdate diff --git a/R/AccumulationExceedingThreshold.R b/R/AccumulationExceedingThreshold.R index f202dca791a07a96d523e8b5680f80159138b00e..7fd78f49f9de6d3fad3a65043ed7a46f2a19e143 100644 --- a/R/AccumulationExceedingThreshold.R +++ b/R/AccumulationExceedingThreshold.R @@ -12,79 +12,93 @@ #' 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 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. -#'@param op An operator '>' (by default), '<', '>=' or '<='. -#'@param diff A logical value indicating whether to accumulate the difference -#' between data and threshold (TRUE) or not (FALSE by default). -#'@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 +#'@param data An 's2dv_cube' object as provided by function \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 +#' 'data'. It can also be a vector with the same length of 'time_dim' from +#' 'data' or a scalar. If we want to use two thresholds: it can be a vector +#' of two scalars, a list of two vectors with the same length of +#' 'time_dim' from 'data' or a list of two multidimensional arrays with the +#' common dimensions of the same length as parameter 'data'. If two thresholds +#' are used, parameter 'op' must be also a vector of two elements. +#'@param op An operator '>' (by default), '<', '>=' or '<='. If two thresholds +#' are used it has to be a vector of a pair of two logical operators: +#' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +#' c('>', '<='), c('>=', '<'),c('>=', '<=')). +#'@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 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 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 +#'@param end An optional parameter to define 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 -#' 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 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 +#' indicate one time dimension. +#'@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. +#'computation. #' -#'@return A 's2dv_cube' object containing the indicator in the element \code{data}. -#' -#'@examples +#'@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. +#'@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' #'DOT <- CST_AccumulationExceedingThreshold(exp, threshold = 280) -#' +#' #'@import multiApply #'@export -CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', - diff = FALSE, - start = NULL, end = NULL, - time_dim = 'ftime', +CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, + start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)['sdate'])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } - if (inherits(threshold, 's2dv_cube')) { - threshold <- threshold$data + + if (length(op) == 1) { + if (inherits(threshold, 's2dv_cube')) { + threshold <- threshold$data + } + } else if (length(op) == 2) { + if (inherits(threshold[[1]], 's2dv_cube')) { + threshold[[1]] <- threshold[[1]]$data + } + if (inherits(threshold[[2]], 's2dv_cube')) { + threshold[[2]] <- threshold[[2]]$data + } } - total <- AccumulationExceedingThreshold(data$data, data$Dates[[1]], - threshold = threshold, op = op, diff = diff, - start = start, end = end, time_dim = time_dim, - na.rm = na.rm, ncores = ncores) + + total <- AccumulationExceedingThreshold(data$data, dates = data$attrs$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$Dates <- SelectPeriodOnDates(dates = data$Dates$start, - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } @@ -103,41 +117,50 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', #'} #' #'@param data A multidimensional array with named dimensions. -#'@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 op An operator '>' (by default), '<', '>=' or '<='. -#'@param diff A logical value indicating whether to accumulate the difference -#' between data and threshold (TRUE) or not (FALSE by default). -#'@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 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 +#'@param threshold If only one threshold is used: it can be a multidimensional +#' array with named dimensions. It must be in the same units and with the +#' common dimensions of the same length as parameter 'data'. It can also be a +#' vector with the same length of 'time_dim' from 'data' or a scalar. If we +#' want to use two thresholds: it can be a vector of two scalars, a list of +#' two vectors with the same length of 'time_dim' from 'data' or a list of +#' two multidimensional arrays with the common dimensions of the same length +#' as parameter 'data'. If two thresholds are used, parameter 'op' must be +#' also a vector of two elements. +#'@param op An operator '>' (by default), '<', '>=' or '<='. If two thresholds +#' are used it has to be a vector of a pair of two logical operators: +#' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +#' c('>', '<='), c('>=', '<'),c('>=', '<=')). +#'@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 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 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 +#'@param end An optional parameter to define 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 -#' 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 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 +#' indicate one time dimension. +#'@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. +#'computation. #' #'@return A multidimensional array with named dimensions containing the -#'indicator in the element \code{data}. +#'aggregated values with dimensions of the input parameter 'data' except the +#'dimension where the indicator has been computed. #' -#'@import multiApply #'@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, time = 214, lon = 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"), @@ -146,12 +169,14 @@ CST_AccumulationExceedingThreshold <- function(data, threshold, op = '>', #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) #'GDD <- AccumulationExceedingThreshold(data, threshold = 0, start = list(1, 4), #' end = list(31, 10)) +#'@import multiApply +#'@importFrom s2dv Reorder #'@export -AccumulationExceedingThreshold <- function(data, threshold, op = '>', - diff = FALSE, +AccumulationExceedingThreshold <- function(data, threshold, op = '>', diff = FALSE, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + # data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } @@ -162,82 +187,247 @@ AccumulationExceedingThreshold <- function(data, threshold, op = '>', dim(data) <- length(data) names(dim(data)) <- time_dim } - if (is.null(threshold)) { + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have named dimensions.") + } + # time_dim + if (!is.character(time_dim)) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!all(time_dim %in% names(dim(data)))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + if (length(time_dim) > 1) { + warning("Parameter 'time_dim' has length greater than 1 and ", + "only the first element will be used.") + time_dim <- time_dim[1] + } + + # op + if (!is.character(op)) { + stop("Parameter 'op' must be a character.") + } + if (length(op) == 1) { + if (!(op %in% c('>', '<', '>=', '<=', '='))) { + stop("Parameter 'op' must be a logical operator.") + } + } else if (length(op) == 2) { + op_list <- list(c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), + c('>', '<'), c('>', '<='), c('>=', '<'), c('>=', '<=')) + if (!any(unlist(lapply(op_list, function(x) all(x == op))))) { + stop("Parameter 'op' is not an accepted pair of logical operators.") + } + } else { + stop("Parameter 'op' must be a logical operator with length 1 or 2.") + } + # threshold + if (is.null(unlist(threshold))) { stop("Parameter 'threshold' cannot be NULL.") } - if (!is.numeric(threshold)) { + if (!is.numeric(unlist(threshold))) { stop("Parameter 'threshold' must be numeric.") } - if (!is.array(threshold) && length(threshold) > 1) { - dim(threshold) <- length(threshold) - names(dim(threshold)) <- time_dim - } else if (length(threshold) == 1) { - dim(threshold) <- NULL - } - if (is.null(names(dim(data)))) { - stop("Parameter 'data' must have named dimensions.") + 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.")) + } + if (!is.numeric(threshold[[1]]) | !is.numeric(threshold[[2]])) { + stop("Parameter 'threshold' must be numeric.") + } + if (length(threshold[[1]]) != length(threshold[[2]])) { + stop("The pair of thresholds must have the same length.") + } + + 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.") + } else { + dim(threshold[[1]]) <- length(threshold[[1]]) + dim(threshold[[2]]) <- length(threshold[[2]]) + names(dim(threshold[[1]])) <- time_dim + names(dim(threshold[[2]])) <- time_dim + } + } else if (is.array(threshold[[1]]) && length(threshold[[1]]) > 1) { + if (is.null(names(dim(threshold[[1]])))) { + stop("If parameter 'threshold' is an array it must have named dimensions.") + } + if (!is.null(dim(threshold[[2]]))) { + if (!all(names(dim(threshold[[1]])) %in% names(dim(threshold[[2]])))) { + stop("The pair of thresholds must have the same dimension names.") + } + } + namedims <- names(dim(threshold[[1]])) + order <- match(namedims, names(dim(threshold[[2]]))) + threshold[[2]] <- aperm(threshold[[2]], order) + if (!all(dim(threshold[[1]]) == dim(threshold[[2]]))) { + stop("The pair of thresholds must have the same dimensions.") + } + 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.")) + } + } + } else if (length(threshold[[1]]) == 1) { + dim(threshold[[1]]) <- NULL + dim(threshold[[2]]) <- NULL + } + } 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.") + } else { + dim(threshold) <- length(threshold) + names(dim(threshold)) <- time_dim + } + } else if (is.array(threshold) && length(threshold) > 1) { + if (is.null(names(dim(threshold)))) { + stop("If parameter 'threshold' is an array it must have named dimensions.") + } + 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.")) + } + } + } else if (length(threshold) == 1) { + dim(threshold) <- NULL + } } - if (is.null(names(dim(threshold))) && length(threshold) > 1) { - stop("Parameter 'threshold' must have named dimensions.") + # ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } } + # dates if (!is.null(dates)) { if (!is.null(start) && !is.null(end)) { 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 (all(time_dim %in% names(dim(threshold)))) { - if (dim(threshold)[time_dim] == dim(data)[time_dim]) { + 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) + } + } + } 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) + } } } data <- SelectPeriodOnData(data, dates, start, end, time_dim = time_dim, ncores = ncores) } } - if (diff == TRUE) { + # diff + if (length(op) == 2 & diff == TRUE) { + 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.") + } data <- Apply(list(data, threshold), target_dims = list(time_dim, NULL), fun = function(x, y) {x - y}, ncores = ncores)$output1 dim(data) <- dim(data)[-length(dim(data))] threshold <- 0 - } - if (is.null(dim(threshold))) { - total <- Apply(list(data), target_dims = time_dim, - fun = .sumexceedthreshold, - y = threshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 - } else if (all(time_dim %in% names(dim(threshold)))) { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, time_dim), - fun = .sumexceedthreshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 - } else if (any(time_dim %in% names(dim(threshold)))) { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, - time_dim[time_dim %in% names(dim(threshold))]), - fun = .sumexceedthreshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 + } + + ### + + if (length(op) > 1) { + thres1 <- threshold[[1]] + thres2 <- threshold[[2]] + if (is.null(dim(thres1))) { + total <- Apply(list(data), target_dims = time_dim, + fun = .sumexceedthreshold, + y = thres1, y2 = thres2, + op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else if (any(time_dim %in% names(dim(thres1)))) { + total <- Apply(list(data, thres1, thres2), + target_dims = list(time_dim, + time_dim[time_dim %in% names(dim(thres1))], + time_dim[time_dim %in% names(dim(thres2))]), + fun = .sumexceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else { + total <- Apply(list(data, thres1, thres2), + target_dims = list(time_dim, thres1 = NULL, thres2 = NULL), + fun = .sumexceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } } else { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, NULL), - fun = .sumexceedthreshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 + if (is.null(dim(threshold))) { + total <- Apply(list(data), target_dims = time_dim, + fun = .sumexceedthreshold, + y = threshold, + op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else if (any(time_dim %in% names(dim(threshold)))) { + total <- Apply(list(data, threshold), + target_dims = list(time_dim, + time_dim[time_dim %in% names(dim(threshold))]), + fun = .sumexceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else { + total <- Apply(list(data, threshold), + target_dims = list(time_dim, NULL), + fun = .sumexceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } } return(total) } -.sumexceedthreshold <- function(x, y, op, na.rm) { - if (op == '>') { - res <- sum(x[x > y], na.rm = na.rm) - } else if (op == '<') { - res <- sum(x[x < y], na.rm = na.rm) - } else if (op == '<=') { - res <- sum(x[x <= y], na.rm = na.rm) + +.sumexceedthreshold <- function(x, y, y2 = NULL, op, na.rm) { + y <- as.vector(y) + y2 <- as.vector(y2) + if (is.null(y2)) { + if (op == '>') { + res <- sum(x[x > y], na.rm = na.rm) + } else if (op == '<') { + res <- sum(x[x < y], na.rm = na.rm) + } else if (op == '<=') { + res <- sum(x[x <= y], na.rm = na.rm) + } else if (op == '>=') { + res <- sum(x[x >= y], na.rm = na.rm) + } else { + res <- sum(x[x = y], na.rm = na.rm) + } } else { - res <- sum(x[x >= y], na.rm = na.rm) + if (all(op == c('<', '>'))) { + res <- sum(x[x < y & x > y2], na.rm = na.rm) + } else if (all(op == c('<', '>='))) { + res <- sum(x[x < y & x >= y2], na.rm = na.rm) + } else if (all(op == c('<=', '>'))) { + res <- sum(x[x <= y & x > y2], na.rm = na.rm) + } else if (all(op == c('<=', '>='))) { + res <- sum(x[x <= y & x >= y2], na.rm = na.rm) + } else if (all(op == c('>', '<'))) { + res <- sum(x[x > y & x < y2], na.rm = na.rm) + } else if (all(op == c('>', '<='))) { + res <- sum(x[x > y & x <= y2], na.rm = na.rm) + } else if (all(op == c('>=', '<'))) { + res <- sum(x[x >= y & x < y2], na.rm = na.rm) + } else if (all(op == c('>=', '<='))) { + res <- sum(x[x >= y & x <= y2], na.rm = na.rm) + } } + return(res) -} - +} \ No newline at end of file diff --git a/R/MergeRefToExp.R b/R/MergeRefToExp.R index 216dc8e831a8448909a7f1e2284519e216e660e2..fa3dcaf8415b8a36c659b36f0247bd74bb87b308 100644 --- a/R/MergeRefToExp.R +++ b/R/MergeRefToExp.R @@ -46,14 +46,14 @@ #'dim(data_dates) <- c(ftime = 154, sdate = 2) #'data <- NULL #'data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member= 2)) -#'data$Dates$start <- data_dates +#'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) #'ref <- NULL #'ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) -#'ref$Dates$start <- ref_dates +#'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), @@ -61,63 +61,87 @@ #' #'@import multiApply #'@importFrom ClimProjDiags Subset +#'@importFrom s2dv InsertDim #'@export CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, time_dim = 'ftime', sdate_dim = 'sdate', ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data1, 's2dv_cube')) { - stop("Parameter 'ref' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'ref' must be of the class 's2dv_cube'.") } if (!inherits(data2, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") - } - # when subsetting is needed, dimensions are also needed: - if (is.null(dim(data1$Dates$start))) { - if (length(data1$Dates$start) != dim(data1$data)[time_dim]) { - if (length(data1$Dates$start) == - prod(dim(data1$data)[time_dim] * dim(data1$data)['sdate'])) { - dim(data1$Dates$start) <- c(dim(data1$data)[time_dim], - dim(data1$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'data$Dates$start' are missed and", - "all data would be used.") - } + stop("Parameter 'data' 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 } } - # when subsetting is needed, dimensions are also needed: - if (is.null(dim(data2$Dates$start))) { - if (length(data2$Dates$start) != dim(data2$data)[time_dim]) { - if (length(data2$Dates$start) == - prod(dim(data2$data)[time_dim] * dim(data2$data)['sdate'])) { - dim(data2$Dates$start) <- c(dim(data2$data)[time_dim], - dim(data2$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'data$Dates$start' are missed and ", - "all data would be used.") - } + # 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 } } - data1$data <- MergeRefToExp(data1 = data1$data, dates1 = data1$Dates[[1]], + + data1$data <- MergeRefToExp(data1 = data1$data, dates1 = dates1, start1 = start1, end1 = end1, - data2 = data2$data, dates2 = data2$Dates[[1]], + data2 = data2$data, dates2 = dates2, start2, end2, time_dim = time_dim, sdate_dim = sdate_dim, ncores = ncores) - dates1 <- SelectPeriodOnDates(data1$Dates[[1]], start = start1, - end = end1, - time_dim = time_dim) - dates2 <- SelectPeriodOnDates(data2$Dates[[1]], - start = start2, - end = end2, time_dim = time_dim) -# TO DO CONCATENATE DATES - res <- Apply(list(dates1, dates2), target_dims = time_dim, + if (!is.null(dates1)) { + data1$attrs$Dates <- 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) + } + + # 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 + } + 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 + } + } + res <- Apply(list(data1$attrs$Dates, data2$attrs$Dates), target_dims = time_dim, c, output_dims = time_dim, ncores = ncores)$output1 - if (inherits(data1$Dates[[1]], 'Date')) { - data1$Dates <- as.Date(res, origin = '1970-01-01') + if (inherits(data1$attrs$Dates, 'Date')) { + data1$attrs$Dates <- as.Date(res, origin = '1970-01-01') } else { - data1$Dates <- as.POSIXct(res*3600*24, origin = '1970-01-01', tz = 'UTC') + data1$attrs$Dates <- as.POSIXct(res*3600*24, origin = '1970-01-01', tz = 'UTC') } + + if (remove_dates1_dim) { + dim(data1$attrs$Dates) <- NULL + } + if (remove_dates2_dim) { + dim(data2$attrs$Dates) <- NULL + } + return(data1) } @@ -131,7 +155,7 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #'steps. #' #'@param data1 A multidimensional array with named dimensions. -#'@param dates1 a vector of dates or a multidimensional array of dates with +#'@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 @@ -151,7 +175,8 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #'@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. +#' 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. #'@param ncores An integer indicating the number of cores to use in parallel @@ -172,15 +197,18 @@ CST_MergeRefToExp <- function(data1, data2, start1, end1, start2, end2, #'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)) +#' start2 = list(1, 7), end = list(21, 9), +#' time_dim = 'time') #' #'@import multiApply #'@importFrom ClimProjDiags Subset #'@importFrom s2dv InsertDim #'@export -MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, end2, - time_dim = 'time', sdate_dim = 'sdate', - ncores = NULL) { +MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, + end2, time_dim = 'ftime', sdate_dim = 'sdate', + ncores = NULL) { + # Input checks + # data if (!is.array(data1)) { dim(data1) <- c(length(data1)) names(dim(data1)) <- time_dim @@ -189,20 +217,24 @@ MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, en dim(data2) <- c(length(data2)) names(dim(data2)) <- time_dim } - 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 - } - 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 + # 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 + } + 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 + } + data1 <- SelectPeriodOnData(data1, dates = dates1, start = start1, + end = end1, time_dim = time_dim, ncores = ncores) } - data1 <- SelectPeriodOnData(data1, dates = dates1, start = start1, - end = end1, time_dim = time_dim, ncores = ncores) + # 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))) { @@ -220,8 +252,8 @@ MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, en dif_dims <- which(names(dim(data2)) %in% names(dim(data1)) == FALSE) if (length(dif_dims) > 0) { for (i in dif_dims) { - data1 <- s2dv::InsertDim(data1, posdim = i, lendim = dim(data2)[i], - name = names(dim(data2))[i]) + data1 <- InsertDim(data1, posdim = i, lendim = dim(data2)[i], + name = names(dim(data2))[i]) } } } @@ -230,13 +262,15 @@ MergeRefToExp <- function(data1, dates1, start1, end1, data2, dates2, start2, en dif_dims <- which(names(dim(data1)) %in% names(dim(data2)) == FALSE) if (length(dif_dims) > 0) { for (i in dif_dims) { - data2 <- s2dv::InsertDim(data2, posdim = i, lendim = dim(data1)[i], - name = names(dim(data1))[i]) + data2 <- InsertDim(data2, posdim = i, lendim = dim(data1)[i], + name = names(dim(data1))[i]) } } } - data2 <- SelectPeriodOnData(data2, dates = dates2, start = start2, - end = end2, time_dim = time_dim, ncores = ncores) + 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 return(data1) diff --git a/R/PeriodAccumulation.R b/R/PeriodAccumulation.R index 0b3fde5a909e212859875e07a70fb79a424410bf..d181d8eeaa71100948ffa1594fce8d6ebadd376f 100644 --- a/R/PeriodAccumulation.R +++ b/R/PeriodAccumulation.R @@ -41,53 +41,50 @@ #'TP <- CST_PeriodAccumulation(exp) #'exp$data <- array(rnorm(5 * 3 * 214 * 2), #' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates[[1]] <- 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$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)) #'dim(SprR$data) -#'head(SprR$Dates) +#'head(SprR$attrs$Dates) #'HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10)) #'dim(HarR$data) -#'head(HarR$Dates) +#'head(HarR$attrs$Dates) #' #'@import multiApply #'@export CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)['sdate'])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } - total <- PeriodAccumulation(data$data, data$Dates[[1]], start, end, - time_dim = time_dim, na.rm = na.rm, ncores = ncores) + + 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$Dates <- SelectPeriodOnDates(dates = data$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } + #'Period Accumulation on multidimensional array objects #' #'Period Accumulation computes the sum (accumulation) of a given variable in a @@ -144,8 +141,8 @@ CST_PeriodAccumulation <- function(data, start = NULL, end = NULL, #'@import multiApply #'@export PeriodAccumulation <- function(data, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, - ncores = NULL) { + time_dim = 'time', na.rm = FALSE, + ncores = NULL) { if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } diff --git a/R/PeriodMean.R b/R/PeriodMean.R index 97f99c3c309dad36392a23d214148c188a3d1290..85a12a74272726c3694425fe1728181409d956b1 100644 --- a/R/PeriodMean.R +++ b/R/PeriodMean.R @@ -37,10 +37,10 @@ #'exp <- NULL #'exp$data <- array(rnorm(45), dim = c(member = 7, ftime = 8)) #'class(exp) <- 's2dv_cube' -#'exp$Dates$start <- 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")) +#'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) #' #'@import multiApply @@ -48,32 +48,28 @@ CST_PeriodMean <- function(data, start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { -# Consider to add an option for providing tx and tn in data + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)['sdate'])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed/unmatched. All data would be used.") - } - } + 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 } } - total <- PeriodMean(data = data$data, dates = data$Dates[[1]], start, end, + + total <- PeriodMean(data = 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$Dates <- SelectPeriodOnDates(dates = data$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } diff --git a/R/QThreshold.R b/R/QThreshold.R index 8eb950a76a255138e5c930c3a2d4f0414496c605..e86b95a0dcb634326356a6283db8d837e1b3c185 100644 --- a/R/QThreshold.R +++ b/R/QThreshold.R @@ -59,50 +59,45 @@ #'exp_probs <- CST_QThreshold(exp, threshold) #'exp$data <- array(rnorm(5 * 3 * 214 * 2), #' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates[[1]] <- 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$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) #' #'@import multiApply #'@importFrom ClimProjDiags Subset #'@export CST_QThreshold <- function(data, threshold, start = NULL, end = NULL, - time_dim = 'ftime', memb_dim = 'member', sdate_dim = 'sdate', - ncores = NULL) { - if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + time_dim = 'ftime', memb_dim = 'member', + sdate_dim = 'sdate', ncores = NULL) { + # Check 's2dv_cube' + if (!inherits(data, 's2dv_cube')) { + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)[sdate_dim])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)[sdate_dim]) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } if (inherits(threshold, 's2dv_cube')) { threshold <- threshold$data } - probs <- QThreshold(data$data, threshold, data$Dates[[1]], start, end, - time_dim = time_dim, memb_dim = memb_dim, + probs <- QThreshold(data$data, threshold, dates = data$attrs$Dates, + start, end, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim, ncores = ncores) data$data <- probs if (!is.null(start) && !is.null(end)) { - data$Dates <- SelectPeriodOnDates(dates = data$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } @@ -178,7 +173,6 @@ QThreshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } - if (!is.array(data)) { dim(data) <- c(length(data), 1) names(dim(data)) <- c(memb_dim, sdate_dim) diff --git a/R/SelectPeriodOnData.R b/R/SelectPeriodOnData.R index 3c162dd746340feb909a9a19ea615ee9081a94a1..b9cf8ac3966bca04dee0c806b0c2d3421de259f2 100644 --- a/R/SelectPeriodOnData.R +++ b/R/SelectPeriodOnData.R @@ -24,67 +24,63 @@ #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), #' c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates$start <- 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$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) #'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', ncores = NULL) { +CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', + ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)['sdate'])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + if (is.null(dim(data$attrs$Dates))) { + warning("Dimensions in 'data' element 'Dates$start' are missed and ", + "all data would be used.") } } - res <- SelectPeriodOnData(data$data, data$Dates[[1]], + + res <- SelectPeriodOnData(data$data, data$attrs$Dates, start = start, end = end, time_dim = time_dim, ncores = ncores) data$data <- res if (!is.null(start) && !is.null(end)) { - data$Dates <- SelectPeriodOnDates(dates = data$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } - #' Select a period on Data on multidimensional array objects #' #' Auxiliary function to subset data for a specific period. #' -#'@param data A multidimensional array with named dimensions. -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions. -#'@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. -#'@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. +#'@param data A multidimensional array with named dimensions with at least the +#' time dimension specified in parameter 'time_dim'. All common dimensions +#' with 'dates' parameter need to have the same length. +#'@param dates An array of dates with named dimensions with at least the time +#' dimension specified in parameter 'time_dim'. All common dimensions with +#' 'data' parameter need to have the same length. +#'@param start A list with two elements to define the initial date of the period +#' to select from the data. The first element is the initial day of the period +#' and the second element is the initial month of the period. +#'@param end A list with two elements to define the final date of the period +#' 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'. More than one -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. +#' compute select the dates. By default, it is set to 'ftime'. Parameters +#' 'data' and 'dates' #'@param ncores An integer indicating the number of cores to use in parallel #' computation. #' @@ -103,11 +99,11 @@ CST_SelectPeriodOnData <- function(data, start, end, time_dim = 'ftime', ncores #' as.Date("30-11-2002", format = "%d-%m-%Y"), by = 'day')) #'dim(Dates) <- c(ftime = 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 = 'ftime', ncores = NULL) { if (is.null(dim(dates))) { dim(dates) <- length(dates) names(dim(dates)) <- time_dim @@ -116,6 +112,7 @@ SelectPeriodOnData <- function(data, dates, start, end, dim(data) <- length(data) names(dim(data)) <- time_dim } + res <- Apply(list(dates), target_dims = time_dim, fun = .position, ini_day = start[[1]], ini_month = start[[2]], @@ -149,6 +146,16 @@ SelectPeriodOnData <- function(data, dates, start, end, return(res) }, output_dims = time_dim, ncores = ncores)$output1 } + names_res <- sort(names(dim(res))) + names_data <- sort(names(dim(data))) + if (!all(names_res %in% names_data)) { + dim_remove <- names_res[-which(names_res %in% names_data)] + 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) } diff --git a/R/SelectPeriodOnDates.R b/R/SelectPeriodOnDates.R index a9c8d9c834a9b8a4963e71d78455b3121737c926..09633dd605100f8fb964ad30acb1792d3f227cac 100644 --- a/R/SelectPeriodOnDates.R +++ b/R/SelectPeriodOnDates.R @@ -2,8 +2,7 @@ #' #' Auxiliary function to subset dates for a specific period. #' -#'@param dates A vector of dates or a multidimensional array of dates with named -#' dimensions. +#'@param dates An array of dates with named dimensions. #'@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. @@ -30,15 +29,18 @@ #' 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) #'Period <- SelectPeriodOnDates(Dates, start = list(21, 6), end = list(21, 9)) #'@export SelectPeriodOnDates <- function(dates, start, end, time_dim = 'ftime', ncores = NULL) { - # TODO: consider NAs if (is.null(dim(dates))) { dim(dates) <- length(dates) names(dim(dates)) <- time_dim } + + # TODO: consider NAs + res <- Apply(list(dates), target_dims = time_dim, fun = .position, ini_day = start[[1]], ini_month = start[[2]], diff --git a/R/Threshold.R b/R/Threshold.R index 0117952a9ece29ca03caa68b1880c836455016e7..3122c1289394f9e6039c2e462b1776f448a49519 100644 --- a/R/Threshold.R +++ b/R/Threshold.R @@ -41,47 +41,44 @@ #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2), #' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates$start <- 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$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')) #'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', sdate_dim = 'sdate', - na.rm = FALSE, ncores = NULL) { + time_dim = 'ftime', memb_dim = 'member', + sdate_dim = 'sdate', na.rm = FALSE, + ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)[sdate_dim])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)[sdate_dim]) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } - thres <- Threshold(data$data, threshold, data$Dates[[1]], start, end, + + thres <- Threshold(data$data, threshold, dates = data$attrs$Dates, start, end, time_dim = time_dim, memb_dim = memb_dim, sdate_dim = sdate_dim, na.rm = na.rm, ncores = ncores) data$data <- thres if (!is.null(start) && !is.null(end)) { - data$Dates <- SelectPeriodOnDates(dates = data$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } @@ -145,7 +142,6 @@ Threshold <- function(data, threshold, dates = NULL, start = NULL, end = NULL, if (!is.numeric(data)) { stop("Parameter 'data' must be numeric.") } - if (!is.array(data)) { dim(data) <- c(length(data), 1) names(dim(data)) <- c(memb_dim, sdate_dim) diff --git a/R/TotalSpellTimeExceedingThreshold.R b/R/TotalSpellTimeExceedingThreshold.R index ac2261ae3380e12245fbbb705ac2535fa95fcc8e..3ee22a27b21114a970476974067366adca2ffc7c 100644 --- a/R/TotalSpellTimeExceedingThreshold.R +++ b/R/TotalSpellTimeExceedingThreshold.R @@ -18,14 +18,21 @@ #' #'@param data An 's2dv_cube' object as provided by function \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. If -#' \code{timd_dim} is in the dimension (with the same length as \code{data}), -#' the comparison will be done day by day. +#'@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 +#' 'data'. It can also be a vector with the same length of 'time_dim' from +#' 'data' or a scalar. If we want to use two thresholds: it can be a vector +#' of two scalars, a list of two vectors with the same length of +#' 'time_dim' from 'data' or a list of two multidimensional arrays with the +#' common dimensions of the same length as parameter 'data'. If two thresholds +#' are used, parameter 'op' must be also a vector of two elements. #'@param spell A scalar indicating the minimum length of the spell. -#'@param op An operator '>' (by default), '<', '>=' or '<='. -#'@param start An optional parameter to defined the initial date of the period +#'@param op An operator '>' (by default), '<', '>=' or '<='. If two thresholds +#' are used it has to be a vector of a pair of two logical operators: +#' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +#' c('>', '<='), c('>=', '<'),c('>=', '<=')). +#'@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 #' to NULL and the indicator is computed using all the data provided in @@ -35,25 +42,24 @@ #' 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 -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. +#' compute the indicator. By default, it is set to 'ftime'. 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 indicator in the element -#'\code{data}. +#'@return An 's2dv_cube' object containing the number of days that are part of a +#'spell within a threshold in element \code{data}. #' #'@examples #'exp <- NULL #'exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, #' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates$start <- 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$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')) #'class(exp) <- 's2dv_cube' #'TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3) #' @@ -63,37 +69,44 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> start = NULL, end = NULL, time_dim = 'ftime', ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)['sdate'])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } - if (inherits(threshold, 's2dv_cube')) { - threshold <- threshold$data + + if (length(op) == 1) { + if (inherits(threshold, 's2dv_cube')) { + threshold <- threshold$data + } + } else if (length(op) == 2) { + if (inherits(threshold[[1]], 's2dv_cube')) { + threshold[[1]] <- threshold[[1]]$data + } + if (inherits(threshold[[2]], 's2dv_cube')) { + threshold[[2]] <- threshold[[2]]$data + } } - total <- TotalSpellTimeExceedingThreshold(data$data, data$Dates[[1]], - threshold = threshold, spell = spell, op = op, - start = start, end = end, time_dim = time_dim, + + total <- TotalSpellTimeExceedingThreshold(data$data, data$attrs$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$Dates <- SelectPeriodOnDates(dates = data$Dates$start, - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } @@ -116,12 +129,20 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #'@seealso [Threshold()] and [AbsToProbs()]. #' #'@param data A multidimensional array with named dimensions. -#'@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. If \code{timd_dim} is in the dimension (with the -#' same length as \code{data}), the comparison will be done day by day. +#'@param threshold If only one threshold is used: it can be a multidimensional +#' array with named dimensions. It must be in the same units and with the +#' common dimensions of the same length as parameter 'data'. It can also be a +#' vector with the same length of 'time_dim' from 'data' or a scalar. If we +#' want to use two thresholds: it can be a vector of two scalars, a list of +#' two vectors with the same length of 'time_dim' from 'data' or a list of +#' two multidimensional arrays with the common dimensions of the same length +#' as parameter 'data'. If two thresholds are used, parameter 'op' must be +#' also a vector of two elements. #'@param spell A scalar indicating the minimum length of the spell. -#'@param op An operator '>' (by default), '<', '>=' or '<='. +#'@param op An operator '>' (by default), '<', '>=' or '<='. If two thresholds +#' 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. @@ -130,34 +151,36 @@ CST_TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '> #' 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 +#'@param end An optional parameter to define 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 -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. +#' compute the indicator. By default, it is set to 'ftime'. It can only +#' indicate one time dimension. #'@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}. +#'@return A multidimensional array with named dimensions containing the number +#'of days that are part of a spell within a threshold with dimensions of the +#'input parameter 'data' except the dimension where the indicator has been +#'computed. #' #'@details This function considers NA values as the end of the spell. For a #'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, time = 20, lat = 4)) +#'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) #' #'@import multiApply #'@export -TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', dates = NULL, - start = NULL, end = NULL, time_dim = 'time', - ncores = NULL) { +TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', + dates = NULL, start = NULL, end = NULL, + time_dim = 'ftime', ncores = NULL) { + # data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } @@ -168,62 +191,232 @@ TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', d dim(data) <- length(data) names(dim(data)) <- time_dim } - if (is.null(threshold)) { + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have named dimensions.") + } + # time_dim + if (!is.character(time_dim)) { + stop("Parameter 'time_dim' must be a character string.") + } + if (!all(time_dim %in% names(dim(data)))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") + } + if (length(time_dim) > 1) { + warning("Parameter 'time_dim' has length greater than 1 and ", + "only the first element will be used.") + time_dim <- time_dim[1] + } + # op + if (!is.character(op)) { + stop("Parameter 'op' must be a character.") + } + if (length(op) == 1) { + if (!(op %in% c('>', '<', '>=', '<=', '='))) { + stop("Parameter 'op' must be a logical operator.") + } + } else if (length(op) == 2) { + op_list <- list(c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), + c('>', '<'), c('>', '<='), c('>=', '<'), c('>=', '<=')) + if (!any(unlist(lapply(op_list, function(x) all(x == op))))) { + stop("Parameter 'op' is not an accepted pair of logical operators.") + } + } else { + stop("Parameter 'op' must be a logical operator with length 1 or 2.") + } + # threshold + if (is.null(unlist(threshold))) { stop("Parameter 'threshold' cannot be NULL.") } - if (!is.numeric(threshold)) { + if (!is.numeric(unlist(threshold))) { stop("Parameter 'threshold' must be numeric.") } - if (is.null(names(dim(data)))) { - stop("Parameter 'data' must have named dimensions.") + 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.")) + } + if (!is.numeric(threshold[[1]]) | !is.numeric(threshold[[2]])) { + stop("Parameter 'threshold' must be numeric.") + } + if (length(threshold[[1]]) != length(threshold[[2]])) { + stop("The pair of thresholds must have the same length.") + } + 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.") + } else { + dim(threshold[[1]]) <- length(threshold[[1]]) + dim(threshold[[2]]) <- length(threshold[[2]]) + names(dim(threshold[[1]])) <- time_dim + names(dim(threshold[[2]])) <- time_dim + } + } else if (is.array(threshold[[1]]) && length(threshold[[1]]) > 1) { + if (is.null(names(dim(threshold[[1]])))) { + stop("If parameter 'threshold' is an array it must have named dimensions.") + } + if (!is.null(dim(threshold[[2]]))) { + if (!all(names(dim(threshold[[1]])) %in% names(dim(threshold[[2]])))) { + stop("The pair of thresholds must have the same dimension names.") + } + } + namedims <- names(dim(threshold[[1]])) + order <- match(namedims, names(dim(threshold[[2]]))) + threshold[[2]] <- aperm(threshold[[2]], order) + if (!all(dim(threshold[[1]]) == dim(threshold[[2]]))) { + stop("The pair of thresholds must have the same dimensions.") + } + 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.")) + } + } + } else if (length(threshold[[1]]) == 1) { + dim(threshold[[1]]) <- NULL + dim(threshold[[2]]) <- NULL + } + } 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.") + } else { + dim(threshold) <- length(threshold) + names(dim(threshold)) <- time_dim + } + } else if (is.array(threshold) && length(threshold) > 1) { + if (is.null(names(dim(threshold)))) { + stop("If parameter 'threshold' is an array it must have named dimensions.") + } + 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.")) + } + } + } else if (length(threshold) == 1) { + dim(threshold) <- NULL + } } + # spell + if (!is.numeric(spell) | length(spell) != 1) { + stop("Parameter 'spell' must be a scalar.") + } + # ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") + } + } + # dates if (!is.null(dates)) { if (!is.null(start) && !is.null(end)) { 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 (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) + 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) + } + } + } 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) + } } } data <- SelectPeriodOnData(data, dates, start, end, time_dim = time_dim, ncores = ncores) } } - if (is.null(dim(threshold))) { - total <- Apply(list(data), target_dims = time_dim, - fun = .totalspellthres, - threshold = threshold, spell = spell, op = op, - ncores = ncores)$output1 - } else if (any(time_dim %in% names(dim(threshold)))) { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, - time_dim[time_dim %in% names(dim(threshold))]), - fun = .totalspellthres, spell = spell, op = op, - ncores = ncores)$output1 + if (length(op) > 1) { + thres1 <- threshold[[1]] + thres2 <- threshold[[2]] + if (is.null(dim(thres1))) { + total <- Apply(list(data), target_dims = time_dim, + fun = .totalspellthres, y = thres1, y2 = thres2, + spell = spell, op = op, + ncores = ncores)$output1 + } else if (any(time_dim %in% names(dim(thres1)))) { + total <- Apply(list(data, thres1, thres2), + target_dims = list(time_dim, + time_dim[time_dim %in% names(dim(thres1))], + time_dim[time_dim %in% names(dim(thres2))]), + fun = .totalspellthres, spell = spell, op = op, + ncores = ncores)$output1 + + } else { + total <- Apply(list(data, thres1, thres2), + target_dims = list(time_dim, thres1 = NULL, thres2 = NULL), + fun = .totalspellthres, spell = spell, op = op, + ncores = ncores)$output1 + } } else { - total <- Apply(list(data, threshold), target_dims = list(time_dim, NULL), - fun = .totalspellthres, spell = spell, op = op, - ncores = ncores)$output1 + if (is.null(dim(threshold))) { + total <- Apply(list(data), target_dims = time_dim, + fun = .totalspellthres, + y = threshold, spell = spell, op = op, + ncores = ncores)$output1 + } else if (any(time_dim %in% names(dim(threshold)))) { + total <- Apply(list(data, threshold), + target_dims = list(time_dim, + time_dim[time_dim %in% names(dim(threshold))]), + fun = .totalspellthres, spell = spell, op = op, + ncores = ncores)$output1 + + } else { + total <- Apply(list(data, threshold), + target_dims = list(time_dim, NULL), + fun = .totalspellthres, spell = spell, op = op, + ncores = ncores)$output1 + } } return(total) } -.totalspellthres <- function(data, threshold, spell, op = '>') { - # data a time serie, threshold single value: - if (op == '>') { - exceed <- data > threshold - } else if (op == '<') { - exceed <- data < threshold - } else if (op == '<=') { - exceed <- data <= threshold +.totalspellthres <- function(x, y, y2 = NULL, spell, op = '>') { + y <- as.vector(y) + y2 <- as.vector(y2) + if (is.null(y2)) { + if (op == '>') { + exceed <- x > y + } else if (op == '<') { + exceed <- x < y + } else if (op == '<=') { + exceed <- x <= y + } else { + exceed <- x >= y + } } else { - exceed <- data >= threshold + if (all(op == c('<', '>'))) { + exceed <- x < y & x > y2 + } else if (all(op == c('<', '>='))) { + exceed <- x < y & x >= y2 + } else if (all(op == c('<=', '>'))) { + exceed <- x <= y & x > y2 + } else if (all(op == c('<=', '>='))) { + exceed <- x <= y & x >= y2 + } else if (all(op == c('>', '<'))) { + exceed <- x > y & x < y2 + } else if (all(op == c('>', '<='))) { + exceed <- x > y & x <= y2 + } else if (all(op == c('>=', '<'))) { + exceed <- x >= y & x < y2 + } else if (all(op == c('>=', '<='))) { + exceed <- x >= y & x <= y2 + } } + spells_exceed <- sequence(rle(as.character(exceed))$lengths) spells_exceed[exceed == FALSE] <- NA pos_spells <- which(spells_exceed == spell) @@ -237,4 +430,4 @@ TotalSpellTimeExceedingThreshold <- function(data, threshold, spell, op = '>', d return(days) }))) return(total) -} +} \ No newline at end of file diff --git a/R/TotalTimeExceedingThreshold.R b/R/TotalTimeExceedingThreshold.R index ec25244d879adf3cd6d561e3b4aff5a6bc31bfbd..ceda1eee6ee47ef0e08ad0a1649d93e986286df2 100644 --- a/R/TotalTimeExceedingThreshold.R +++ b/R/TotalTimeExceedingThreshold.R @@ -1,12 +1,12 @@ #'Total Time of a variable Exceeding (not exceeding) a Threshold #' -#'The Total Time of a variable exceeding (or not) a Threshold returns the total -#'number of days (if the data provided is daily, or the corresponding units to -#'the data frequency provided) that a variable is exceeding a threshold during a -#'period. The threshold provided must be in the same units than the variable -#'units, i.e. to use a percentile as a scalar, -#'the function \code{AbsToProbs} or \code{QThreshold} may be needed (see -#'examples). Providing maximum temperature daily data, the following agriculture +#'The Total Time of a variable exceeding (or not) a Threshold. It returns the +#'total number of days (if the data provided is daily, or the corresponding +#'units of the data frequency) that a variable is exceeding a threshold +#'during a period. The threshold provided must be in the same units as the +#'variable units, i.e. to use a percentile as a scalar, the function +#'\code{AbsToProbs} or \code{QThreshold} may be needed (see examples). +#'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 @@ -22,43 +22,50 @@ #' #'@param data An 's2dv_cube' object as provided by function \code{CST_Load} in #' package CSTools. -#'@param threshold An 's2dv_cube' object as output of a 'CST_' function in the -#' same units as parameter \code{data} and with the common dimensions of the -#' element \code{data} of the same length (e.g. an array with the same lengths -#' of longitude and latitude). A single scalar is also possible (for the case -#' of comparing all grid points with the same scalar). -#'@param op An operator '>' (by default), '<', '>=' or '<='. -#'@param start An optional parameter to defined the initial date of the period +#'@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 +#' 'data'. It can also be a vector with the same length of 'time_dim' from +#' 'data' or a scalar. If we want to use two thresholds: it can be a vector +#' of two scalars, a list of two vectors with the same length of +#' 'time_dim' from 'data' or a list of two multidimensional arrays with the +#' common dimensions of the same length as parameter 'data'. If two thresholds +#' are used, parameter 'op' must be also a vector of two elements. +#'@param op An operator '>' (by default), '<', '>=' or '<='. If two thresholds +#' are used it has to be a vector of a pair of two logical operators: +#' c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +#' c('>', '<='), c('>=', '<'),c('>=', '<=')). +#'@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 #' 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 +#'@param end An optional parameter to define 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 -#' dimension name matching the dimensions provided in the object -#' \code{data$data} can be specified. +#' compute the indicator. By default, it is set to 'ftime'. It can only +#' indicate one time dimension. #'@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}. +#'@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. #' #'@examples #'exp <- NULL #'exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*280), #' c(member = 5, sdate = 3, ftime = 214, lon = 2)) -#'exp$Dates$start <- 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$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')) #'class(exp) <- 's2dv_cube' #'DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 280) #' @@ -68,53 +75,60 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', start = NULL, end = NULL, time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + # Check 's2dv_cube' if (!inherits(data, 's2dv_cube')) { - stop("Parameter 'data' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'data' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(data$Dates$start))) { - if (length(data$Dates$start) != dim(data$data)[time_dim]) { - if (length(data$Dates$start) == - prod(dim(data$data)[time_dim] * dim(data$data)['sdate'])) { - dim(data$Dates$start) <- c(dim(data$data)[time_dim], - dim(data$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + 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 } } - if (inherits(threshold, 's2dv_cube')) { - threshold <- threshold$data + + if (length(op) == 1) { + if (inherits(threshold, 's2dv_cube')) { + threshold <- threshold$data + } + } else if (length(op) == 2) { + if (inherits(threshold[[1]], 's2dv_cube')) { + threshold[[1]] <- threshold[[1]]$data + } + if (inherits(threshold[[2]], 's2dv_cube')) { + threshold[[2]] <- threshold[[2]]$data + } } - total <- TotalTimeExceedingThreshold(data$data, data$Dates[[1]], + total <- TotalTimeExceedingThreshold(data$data, dates = data$attrs$Dates, threshold = threshold, op = op, - start = start, end = end, time_dim = time_dim, - na.rm = na.rm, ncores = ncores) + 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$Dates <- SelectPeriodOnDates(dates = data$Dates$start, - start = start, end = end, - time_dim = time_dim, ncores = ncores) + data$attrs$Dates <- SelectPeriodOnDates(dates = data$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(data) } #'Total Time of a variable Exceeding (not exceeding) a Threshold #' -#'The Total Time of a variable exceeding (or not) a Threshold returns the total -#'number of days (if the data provided is daily, or the corresponding units to -#'the data frequency provided) that a variable is exceeding a threshold during a -#'period. The threshold provided must be in the same units than the variable -#'units, i.e. to use a percentile as a threshold, the function \code{Threshold} -#'or \code{QThreshold} may be needed (see examples). Providing maximum -#'temperature daily data, the following agriculture indices for heat stress can -#'be obtained by using this function: +#'The Total Time of a variable exceeding (or not) a Threshold. It returns the +#'total number of days (if the data provided is daily, or the corresponding +#'units of the data frequency) that a variable is exceeding a threshold +#'during a period. The threshold provided must be in the same units as the +#'variable units, i.e. to use a percentile as a scalar, the function +#'\code{AbsToProbs} or \code{QThreshold} may be needed (see examples). +#'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} +#' 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 @@ -124,35 +138,42 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #'} #' #'@param data A multidimensional array with named dimensions. -#'@param threshold A multidimensional array with named dimensions in the same -#' units as parameter \code{data} and with the common dimensions of the element -#' \code{data} of the same length (e.g. an array with the same lengths of -#' longitude and latitude). A single scalar is also possible (for the case of -#' comparing all grid points with the same scalar). -#'@param op A operator '>' (by default), '<', '>=' or '<='. +#'@param threshold If only one threshold is used: it can be a multidimensional +#' array with named dimensions. It must be in the same units and with the +#' common dimensions of the same length as parameter 'data'. It can also be a +#' vector with the same length of 'time_dim' from 'data' or a scalar. If we +#' want to use two thresholds: it can be a vector of two scalars, a list of +#' two vectors with the same length of 'time_dim' from 'data' or a list of +#' two multidimensional arrays with the common dimensions of the same length +#' as parameter 'data'. If two thresholds are used, parameter 'op' must be +#' also a vector of two elements. +#'@param op An operator '>' (by default), '<', '>=' or '<='. If two thresholds +#' 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 start An optional parameter to defined the initial date of the period +#'@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 #' 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 +#'@param end An optional parameter to define 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. +#' compute the indicator. By default, it is set to 'ftime'. It can only +#' indicate one time dimension. #'@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}. +#'@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. #' #'@examples #'exp <- array(abs(rnorm(5 * 3 * 214 * 2)*280), @@ -163,8 +184,9 @@ CST_TotalTimeExceedingThreshold <- function(data, threshold, op = '>', #'@export TotalTimeExceedingThreshold <- function(data, threshold, op = '>', dates = NULL, start = NULL, end = NULL, - time_dim = 'time', na.rm = FALSE, + time_dim = 'ftime', na.rm = FALSE, ncores = NULL) { + # data if (is.null(data)) { stop("Parameter 'data' cannot be NULL.") } @@ -175,81 +197,225 @@ TotalTimeExceedingThreshold <- function(data, threshold, op = '>', dim(data) <- length(data) names(dim(data)) <- time_dim } - if (is.null(threshold)) { - stop("Parameter 'threshold' cannot be NULL.") + if (is.null(names(dim(data)))) { + stop("Parameter 'data' must have named dimensions.") } - if (!is.numeric(threshold)) { - stop("Parameter 'threshold' must be numeric.") + # time_dim + if (!is.character(time_dim)) { + stop("Parameter 'time_dim' must be a character string.") } - if (!is.array(threshold) && length(threshold) > 1) { - dim(threshold) <- length(threshold) - names(dim(threshold)) <- time_dim - } else if (length(threshold) == 1) { - dim(threshold) <- NULL + if (!all(time_dim %in% names(dim(data)))) { + stop("Parameter 'time_dim' is not found in 'data' dimension.") } - if (is.null(names(dim(data)))) { - stop("Parameter 'data' must have named dimensions.") + if (length(time_dim) > 1) { + warning("Parameter 'time_dim' has length greater than 1 and ", + "only the first element will be used.") + time_dim <- time_dim[1] + } + # op + if (!is.character(op)) { + stop("Parameter 'op' must be a character.") + } + if (length(op) == 1) { + if (!(op %in% c('>', '<', '>=', '<=', '='))) { + stop("Parameter 'op' must be a logical operator.") + } + } else if (length(op) == 2) { + op_list <- list(c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), + c('>', '<'), c('>', '<='), c('>=', '<'), c('>=', '<=')) + if (!any(unlist(lapply(op_list, function(x) all(x == op))))) { + stop("Parameter 'op' is not an accepted pair of logical operators.") + } + } else { + stop("Parameter 'op' must be a logical operator with length 1 or 2.") } - if (is.null(names(dim(threshold))) && length(threshold) > 1) { - stop("Parameter 'threshold' must have named dimensions.") + # threshold + if (is.null(unlist(threshold))) { + stop("Parameter 'threshold' cannot be NULL.") + } + if (!is.numeric(unlist(threshold))) { + stop("Parameter 'threshold' must be numeric.") + } + 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.")) + } + if (!is.numeric(threshold[[1]]) | !is.numeric(threshold[[2]])) { + stop("Parameter 'threshold' must be numeric.") + } + if (length(threshold[[1]]) != length(threshold[[2]])) { + stop("The pair of thresholds must have the same length.") + } + 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.") + } else { + dim(threshold[[1]]) <- length(threshold[[1]]) + dim(threshold[[2]]) <- length(threshold[[2]]) + names(dim(threshold[[1]])) <- time_dim + names(dim(threshold[[2]])) <- time_dim + } + } else if (is.array(threshold[[1]]) && length(threshold[[1]]) > 1) { + if (is.null(names(dim(threshold[[1]])))) { + stop("If parameter 'threshold' is an array it must have named dimensions.") + } + if (!is.null(dim(threshold[[2]]))) { + if (!all(names(dim(threshold[[1]])) %in% names(dim(threshold[[2]])))) { + stop("The pair of thresholds must have the same dimension names.") + } + } + namedims <- names(dim(threshold[[1]])) + order <- match(namedims, names(dim(threshold[[2]]))) + threshold[[2]] <- aperm(threshold[[2]], order) + if (!all(dim(threshold[[1]]) == dim(threshold[[2]]))) { + stop("The pair of thresholds must have the same dimensions.") + } + 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.")) + } + } + } else if (length(threshold[[1]]) == 1) { + dim(threshold[[1]]) <- NULL + dim(threshold[[2]]) <- NULL + } + } 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.") + } else { + dim(threshold) <- length(threshold) + names(dim(threshold)) <- time_dim + } + } else if (is.array(threshold) && length(threshold) > 1) { + if (is.null(names(dim(threshold)))) { + stop("If parameter 'threshold' is an array it must have named dimensions.") + } + 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.")) + } + } + } else if (length(threshold) == 1) { + dim(threshold) <- NULL + } } - common_dims <- which(names(dim(data)) %in% names(dim(threshold))) - if (length(threshold) > 1) { - if (any(dim(data)[common_dims] != - dim(threshold)[which(names(dim(threshold)) %in% names(dim(data)))])) { - stop("Parameter 'data' and 'threshold' must have the same length on common dimensions.") + # ncores + if (!is.null(ncores)) { + if (!is.numeric(ncores) | ncores %% 1 != 0 | ncores <= 0 | + length(ncores) > 1) { + stop("Parameter 'ncores' must be a positive integer.") } - } + } + # dates if (!is.null(dates)) { if (!is.null(start) && !is.null(end)) { 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 (time_dim %in% names(dim(threshold))) { - if (dim(threshold)[time_dim] == dim(data)[time_dim]) { + 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) + 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) + } } } data <- SelectPeriodOnData(data, dates, start, end, time_dim = time_dim, ncores = ncores) } } - if (is.null(dim(threshold))) { - total <- Apply(list(data), target_dims = time_dim, - fun = .exceedthreshold, - y = threshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 - } else if (all(time_dim %in% names(dim(threshold)))) { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, time_dim), - fun = .exceedthreshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 - } else if (any(time_dim %in% names(dim(threshold)))) { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, - time_dim[time_dim %in% names(dim(threshold))]), - fun = .exceedthreshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 + + if (length(op) > 1) { + thres1 <- threshold[[1]] + thres2 <- threshold[[2]] + if (is.null(dim(thres1))) { + total <- Apply(list(data), target_dims = time_dim, + fun = .exceedthreshold, y = thres1, y2 = thres2, + op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else if (any(time_dim %in% names(dim(thres1)))) { + total <- Apply(list(data, thres1, thres2), + target_dims = list(time_dim, + time_dim[time_dim %in% names(dim(thres1))], + time_dim[time_dim %in% names(dim(thres2))]), + fun = .exceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + + } else { + total <- Apply(list(data, thres1, thres2), + target_dims = list(time_dim, thres1 = NULL, thres2 = NULL), + fun = .exceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } } else { - total <- Apply(list(data, threshold), - target_dims = list(time_dim, NULL), - fun = .exceedthreshold, op = op, na.rm = na.rm, - ncores = ncores)$output1 + if (is.null(dim(threshold))) { + total <- Apply(list(data), target_dims = time_dim, + fun = .exceedthreshold, + y = threshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else if (any(time_dim %in% names(dim(threshold)))) { + total <- Apply(list(data, threshold), + target_dims = list(time_dim, + time_dim[time_dim %in% names(dim(threshold))]), + fun = .exceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } else { + total <- Apply(list(data, threshold), + target_dims = list(time_dim, NULL), + fun = .exceedthreshold, op = op, na.rm = na.rm, + ncores = ncores)$output1 + } } return(total) } -.exceedthreshold <- function(x, y, op, na.rm) { - if (op == '>') { - res <- sum(x > y, na.rm = na.rm) - } else if (op == '<') { - res <- sum(x < y, na.rm = na.rm) - } else if (op == '<=') { - res <- sum(x <= y, na.rm = na.rm) + +.exceedthreshold <- function(x, y, y2 = NULL, op = '>', na.rm) { + y <- as.vector(y) + y2 <- as.vector(y2) + if (is.null(y2)) { + if (op == '>') { + res <- sum(x > y, na.rm = na.rm) + } else if (op == '<') { + res <- sum(x < y, na.rm = na.rm) + } else if (op == '<=') { + res <- sum(x <= y, na.rm = na.rm) + } else { + res <- sum(x >= y, na.rm = na.rm) + } } else { - res <- sum(x >= y, na.rm = na.rm) + if (all(op == c('<', '>'))) { + res <- sum(x < y & x > y2, na.rm = na.rm) + } else if (all(op == c('<', '>='))) { + res <- sum(x < y & x >= y2, na.rm = na.rm) + } else if (all(op == c('<=', '>'))) { + res <- sum(x <= y & x > y2, na.rm = na.rm) + } else if (all(op == c('<=', '>='))) { + res <- sum(x <= y & x >= y2, na.rm = na.rm) + } else if (all(op == c('>', '<'))) { + res <- sum(x > y & x < y2, na.rm = na.rm) + } else if (all(op == c('>', '<='))) { + res <- sum(x > y & x <= y2, na.rm = na.rm) + } else if (all(op == c('>=', '<'))) { + res <- sum(x >= y & x < y2, na.rm = na.rm) + } else if (all(op == c('>=', '<='))) { + res <- sum(x >= y & x <= y2, na.rm = na.rm) + } } return(res) -} - +} \ No newline at end of file diff --git a/R/WindCapacityFactor.R b/R/WindCapacityFactor.R index ee542ebe423fc54c57a114755e7905df9fa63214..8ed20844370f7036d2cee074df64eab79308ce18 100644 --- a/R/WindCapacityFactor.R +++ b/R/WindCapacityFactor.R @@ -10,8 +10,9 @@ #'piecewise approximating function to obtain a smooth power curve. Five #'different power curves that span different IEC classes can be selected (see #'below). -#'@references Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, F. J. (2019). -#'Seasonal forecasts of wind power generation. Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 +#'@references Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, +#'F. J. (2019). Seasonal forecasts of wind power generation. +#'Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 #'@references International Standard IEC 61400-1 (third ed.) (2005) #' #'@param wind An s2dv_cube object with instantaneous wind speeds expressed in m/s. @@ -39,48 +40,49 @@ #'@return An s2dv_cube object containing the Wind Capacity Factor (unitless). #' #'@examples -#'wind <- array(rweibull(n = 100, shape = 2, scale = 6), c(member = 10, lat = 2, lon = 5)) -#'wind <- CSTools::s2dv_cube(data = wind, lat = c(40, 41), lon = 1:5, -#' Variable = list(varName = 'sfcWind', level = 'Surface'), -#' Datasets = 'synthetic', when = Sys.time(), -#' Dates = list(start = '1990-01-01 00:00:00', end = '1990-01-01 00:00:00'), -#' source_file = NA) +#'wind <- NULL +#'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), +#' c(member = 10, lat = 2, lon = 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') +#'class(wind) <- 's2dv_cube' #'WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") #' #'@export CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/III", "III"), start = NULL, end = NULL, time_dim = 'ftime', ncores = NULL) { + # Check 's2dv_cube' if (!inherits(wind, 's2dv_cube')) { - stop("Parameter 'wind' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'wind' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(wind$Dates$start))) { - if (length(wind$Dates$start) != dim(wind$data)[time_dim]) { - if (length(wind$Dates$start) == - prod(dim(wind$data)[time_dim] * dim(wind$data)['sdate'])) { - dim(wind$Dates$start) <- c(dim(wind$data)[time_dim], - dim(wind$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + if (is.null(dim(wind$attrs$Dates))) { + warning("Dimensions in 'wind' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL } } - wind$data <- WindCapacityFactor(wind$data, IEC_class = IEC_class, dates = wind$Dates[[1]], - start = start, end = end, ncores = ncores) - if ('Variable' %in% names(wind)) { - if ('varName' %in% names(wind$Variable)) { - wind$Variable$varName <- 'WindCapacityFactor' + + WindCapacity <- WindCapacityFactor(wind = wind$data, IEC_class = IEC_class, + dates = wind$attrs$Dates, start = start, + end = end, ncores = ncores) + wind$data <- WindCapacity + if ('Variable' %in% names(wind$attrs)) { + if ('varName' %in% names(wind$attrs$Variable)) { + wind$attrs$Variable$varName <- 'WindCapacityFactor' } } if (!is.null(start) && !is.null(end)) { - wind$Dates <- SelectPeriodOnDates(dates = wind$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + wind$attrs$Dates <- SelectPeriodOnDates(dates = wind$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(wind) } @@ -96,8 +98,9 @@ CST_WindCapacityFactor <- function(wind, IEC_class = c("I", "I/II", "II", "II/II #'piecewise approximating function to obtain a smooth power curve. Five #'different power curves that span different IEC classes can be selected (see #'below). -#'@references Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, F. J. (2019). -#'Seasonal forecasts of wind power generation. Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 +#'@references Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, +#'F. J. (2019). Seasonal forecasts of wind power generation. +#'Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 #'@references International Standard IEC 61400-1 (third ed.) (2005) #' #'@param wind A multidimensional array, vector or scalar with instantaneous wind @@ -150,17 +153,18 @@ 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 (!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(dates)) { + if (!is.null(start) && !is.null(end)) { + 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) + } + } cf <- wind2CF(wind, pc) + dim(cf) <- dim(wind) return(cf) } diff --git a/R/WindPowerDensity.R b/R/WindPowerDensity.R index bbdd07d87c6b82ce67544366ad042fe273051d99..357820999cb83f3c53bfdb08795d8265094026a9 100644 --- a/R/WindPowerDensity.R +++ b/R/WindPowerDensity.R @@ -30,47 +30,47 @@ #'@return An s2dv_cube object containing Wind Power Density expressed in W/m^2. #' #'@examples -#'wind <- array(rweibull(n = 100, shape = 2, scale = 6), c(member = 10, lat = 2, lon = 5)) -#'wind <- CSTools::s2dv_cube(data = wind, lat = c(40, 41), lon = 1:5, -#' Variable = list(varName = 'sfcWind', level = 'Surface'), -#' Datasets = 'synthetic', when = Sys.time(), -#' Dates = list(start = '1990-01-01 00:00:00', end = '1990-01-01 00:00:00'), -#' source_file = NA) -#'WPD <- CST_WindPowerDensity(wind) +#'wind <- NULL +#'wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), +#' c(member = 10, lat = 2, lon = 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') +#'class(wind) <- 's2dv_cube' +#'WCF <- CST_WindPowerDensity(wind) #' #'@export CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, time_dim = 'ftime', ncores = NULL) { + # Check 's2dv_cube' if (!inherits(wind, 's2dv_cube')) { - stop("Parameter 'wind' must be of the class 's2dv_cube', ", - "as output by CSTools::CST_Load.") + stop("Parameter 'wind' must be of the class 's2dv_cube'.") } - # when subsetting is needed, dimensions are also needed: + # Dates subset if (!is.null(start) && !is.null(end)) { - if (is.null(dim(wind$Dates$start))) { - if (length(wind$Dates$start) != dim(wind$data)[time_dim]) { - if (length(wind$Dates$start) == - prod(dim(wind$data)[time_dim] * dim(wind$data)['sdate'])) { - dim(wind$Dates$start) <- c(dim(wind$data)[time_dim], - dim(wind$data)['sdate']) - } else { - warning("Dimensions in 'data' element 'Dates$start' are missed and ", - "all data would be used.") - } - } + if (is.null(dim(wind$attrs$Dates))) { + warning("Dimensions in 'wind' element 'attrs$Dates' are missed and ", + "all data would be used.") + start <- NULL + end <- NULL } } - wind$data <- WindPowerDensity(wind$data, ro = ro, dates = wind$Dates[[1]], - start = start, end = end, ncores = ncores) - if ('Variable' %in% names(wind)) { - if ('varName' %in% names(wind$Variable)) { - wind$Variable$varName <- 'WindPowerDensity' + WindPower <- WindPowerDensity(wind = wind$data, ro = ro, + dates = wind$attrs$Dates, start = start, + end = end, ncores = ncores) + wind$data <- WindPower + if ('Variable' %in% names(wind$attrs)) { + if ('varName' %in% names(wind$attrs$Variable)) { + wind$attrs$Variable$varName <- 'WindPowerDensity' } } if (!is.null(start) && !is.null(end)) { - wind$Dates <- SelectPeriodOnDates(dates = wind$Dates[[1]], - start = start, end = end, - time_dim = time_dim, ncores = ncores) + wind$attrs$Dates <- SelectPeriodOnDates(dates = wind$attrs$Dates, + start = start, end = end, + time_dim = time_dim, + ncores = ncores) } return(wind) } @@ -115,8 +115,8 @@ CST_WindPowerDensity <- function(wind, ro = 1.225, start = NULL, end = NULL, #'WPD <- WindPowerDensity(wind) #' #'@export -WindPowerDensity <- function(wind, ro = 1.225, dates = NULL, start = NULL, end = NULL, - time_dim = 'time', ncores = NULL) { +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 (!any(c(is.list(start), is.list(end)))) { @@ -127,6 +127,5 @@ WindPowerDensity <- function(wind, ro = 1.225, dates = NULL, start = NULL, end = time_dim = time_dim, ncores = ncores) } } - return(0.5 * ro * wind^3) } diff --git a/R/zzz.R b/R/zzz.R index 52fa2cd557d0d25a7af8269cf46405db97a64359..9b0c6488fb9a91a5c8b5e86bffaa454a7be48379 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -36,7 +36,8 @@ read_pc <- function(file) { pc$points <- rbind(c(0, 0), read.delim(file, comment.char = "#")) # Create an approximating function - pc$fun <- approxfun(pc$points$WindSpeed, pc$points$Power, method = "linear", yleft = NA, yright = 0) + pc$fun <- approxfun(pc$points$WindSpeed, pc$points$Power, method = "linear", + yleft = NA, yright = 0) # Get the rated power from the power values pc$attr$RatedPower <- max(pc$points$Power) @@ -47,16 +48,16 @@ read_pc <- function(file) { #======================= # Evaluate the linear piecewise approximation function with the wind speed inputs to get wind power #======================= -wind2power <- function(wind, pc) -{ power <- pc$fun(wind) +wind2power <- function(wind, pc) { + power <- pc$fun(wind) return(power) } #======================= # Convert wind to power, and divide by rated power to obtain Capacity Factor values #======================= -wind2CF <- function(wind, pc) -{ power <- wind2power(wind, pc) +wind2CF <- function(wind, pc) { + power <- wind2power(wind, pc) CF <- power / pc$attr$RatedPower return(CF) } diff --git a/README.md b/README.md index 2ed5fde1768871aefe4fef51b24a849563cafadc..5521a516c737721659480633a0a5ef715affd14a 100644 --- a/README.md +++ b/README.md @@ -3,26 +3,30 @@ CSIndicators #### Sectoral Indicators for Climate Services Based on Sub-Seasonal to Decadal Climate Predictions -## Description -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. - -## Functions and documentation +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). + +Installation +------------ + +You can then install the public released version of CSIndicators from CRAN: +```r +install.packages("CSIndicators") +``` +Or the development version from the GitLab repository: +```r +# install.packages("devtools") +devtools::install_git("https://earth.bsc.es/gitlab/es/csindicators.git") +``` + +Overview +-------- To learn how to use the package see: - [**Agricultural Indicators**](https://CRAN.R-project.org/package=CSIndicators/vignettes/AgriculturalIndicators.html) - [**Wind Energy Indicators**](https://CRAN.R-project.org/package=CSIndicators/vignettes/EnergyIndicators.html) -Functions documentation can be found [here](https://CRAN.R-project.org/package=CSIndicators/CSIndicators.pdf) +Functions documentation can be found [here](https://CRAN.R-project.org/package=CSIndicators/CSIndicators.pdf). | Function | CST version | Indicators | |--------------------------------|------------------------------------|---------------------------------| @@ -44,30 +48,62 @@ Functions documentation can be found [here](https://CRAN.R-project.org/package=C |SelectPeriodOnData |CST_SelectPeriodOnData| |SelectPeriodOnDates| | -Find the current status of each function in this link: https://docs.google.com/spreadsheets/d/1arqgw-etNPs-XRyMTJ4ekF5YjQxAZBzssxxr2GMXp3c/edit#gid=0. +Find the current status of each function in [this link](https://docs.google.com/spreadsheets/d/1arqgw-etNPs-XRyMTJ4ekF5YjQxAZBzssxxr2GMXp3c/edit#gid=0). *Note: the CST version uses 's2dv_cube' objects as inputs and outputs while the former version uses multidimensional arrays with named dimensions as inputs and outputs* *Note: All functions computing indicators allows to subset a time period if required, although this temporal subsetting can also be done with functions `SelectPeriodOnData` in a separated step.* +#### Object class 's2dv_cube' + +This package is designed to be compatible with other R packages such as [CSTools](https://CRAN.R-project.org/package=CSTools) through a common object: the `s2dv_cube` object class, used in functions with the prefix **CST_**. This object can be created from Start ([startR](https://CRAN.R-project.org/package=startR) package) and from Load ([s2dv](https://CRAN.R-project.org/package=s2dv) package) directly. + +The class `s2dv_cube` is mainly a list of named elements to keep data and metadata in a single object. Basic structure of the object: + +```r +$ data: [data array] +$ dims: [dimensions vector] +$ coords: [List of coordinates vectors] + $ sdate + $ time + $ lon + [...] +$ attrs: [List of the attributes] + $ Variable: + $ varName + $ metadata + $ Datasets + $ Dates + $ source_files + $ when + $ load_parameters +``` + +More information about the `s2dv_cube` object class can be found here: [description of the s2dv_cube object structure document](https://docs.google.com/document/d/1ko37JFl_h6mOjDKM5QSQGikfLBKZq1naL11RkJIwtMM/edit?usp=sharing). + +The current `s2dv_cube` object (CSIndicators 1.0.0 and CSTools 5.0.0) differs from the original object used in the previous versions of the packages. If you have **questions** on this change you can follow some of the points below: + +- [New s2dv_cube object discussion in CSTools](https://earth.bsc.es/gitlab/external/cstools/-/issues/94) +- [How to deal with the compatibility break in CSIndicators](https://earth.bsc.es/gitlab/es/csindicators/-/issues/25) -### How to contribute +Contribute +---------- 1. Open an issue to ask for help or describe a function to be integrated 2. Agree with maintainers (@ngonzal2, @rmarcos, @nperez and @erifarov) on the requirements 3. Create a new branch from master with a meaningful name 4. Once the development is finished, open a merge request to merge the branch on master -*Note: Remember to work with multidimensionals arrays with named dimensions when possible and use multiApply (https://earth.bsc.es/gitlab/ces/multiApply)* +*Note: Remember to work with multidimensionals arrays with named dimensions when possible and use [multiApply](https://earth.bsc.es/gitlab/ces/multiApply).* -### Add a function +#### Add a function To add a new function in this R package, follow this considerations: 1. Each function exposed to the users should be in separate files in the R folder -2. The name of the function should match the name of the file (e.g.: `Function()` included in file **Function.R** +2. The name of the function should match the name of the file (e.g.: `Function()` included in file **Function.R**) 3. The documentation should be in roxygen2 format as a header of the function 4. Once, the function and the documentation is finished, run the command `devtools::document()` in your R terminal to automatically generate the **Function.Rd** file -5. Remember to use R 3.6.1 when doing the development -6. Code format: include spaces between operators (e.g. +, -, &), before { and after ','. The maximum length of lines is of 100 characters (hard limit 80 characters). Number of indentation spaces is 2. +5. Remember to use R 4.1.2 when doing the development +6. Code format: include spaces between operators (e.g. +, -, &), before and after ','. The maximum length of lines is of 100 characters (hard limit 80 characters). Number of indentation spaces is 2. 7. Functions computing Climate indicators should include a temporal subsetting option. Use the already existing functions to adapt your code. diff --git a/inst/doc/paper-figure-PlotForecastPDF.R b/inst/doc/paper-figure-PlotForecastPDF.R new file mode 100644 index 0000000000000000000000000000000000000000..b8867a61c882f4cb6453a64226c0539aae74aa8a --- /dev/null +++ b/inst/doc/paper-figure-PlotForecastPDF.R @@ -0,0 +1,104 @@ +rm(list=ls()) + +### Creation date: January 2023 +# Author: N. Pérez-Zanón +# For CSIndicators package manuscript +# ---------------------------------------- +# Figure 1. sprR probability distribution of the forecast initialised on the 1st +# of April 2022 for the western Iberian peninsula. The daily values of the +# hindcast and forecast have been corrected before calculating the sprR and the +# spatial aggregation. The adjusted hindcast has been used to calculate the +# fRPSS and the terciles and extremes thresholds. +# ---------------------------------------- + +library(CSIndicators) +library(CSTools) +library(zeallot) +library(s2dv) + +S5path <- list(name = 'SEAS5', + path = '/esarchive/exp/ecmwf/system5c3s/$STORE_FREQ$_mean/$VAR_NAME$_s0-24h/$VAR_NAME$_$START_DATE$.nc') + +ERA5path <- list(name = 'ERA5', + path = '/esarchive/recon/ecmwf/era5/$STORE_FREQ$_mean/$VAR_NAME$_f1h-r1440x721cds/$VAR_NAME$_$YEAR$$MONTH$.nc') + +sdates <- paste0(1993:2016, '04', '01') + +c(hcst, hcst_ref) %<-% CST_Load(var = 'prlr', + exp = list(S5path), + obs = list(ERA5path), + sdates = sdates, + lonmin = -10, lonmax = 0, + latmin = 35, latmax = 40, + storefreq = 'daily', + leadtimemin = 1, leadtimemax = 214, + nmember = 25, output = "lonlat") +hcst$data <- hcst$data * 3600 * 24 * 1000 +attributes(hcst$attrs$Variable)$units <- 'mm' +hcst_ref$data <- hcst_ref$data * 3600 * 24 * 1000 +attributes(hcst_ref$attrs$Variable)$units <- 'mm' + + +c(fcst, obs) %<-% CST_Load(var = 'prlr', + exp = list(S5path), + obs = list(ERA5path), + sdates = '20220401', + lonmin = -10, lonmax = 0, + latmin = 35, latmax = 40, + storefreq = 'daily', + leadtimemin = 1, leadtimemax = 214, + nmember = 50, output = "lonlat") +fcst$data <- fcst$data * 1000 * 3600 * 24 +attributes(fcst$attrs$Variable)$units <- 'mm' +obs$data <- obs$data * 1000 * 3600 * 24 +attributes(obs$attrs$Variable)$units <- 'mm' + + +fcst_QM <- CST_QuantileMapping(exp = hcst, + obs = hcst_ref, + exp_cor = fcst, wet = TRUE, + ncores = 6) +hcst_QM <- CST_QuantileMapping(exp = hcst, + obs = hcst_ref, wet = TRUE, + ncores = 6) + +sprR_fcst <- CST_PeriodAccumulation(fcst_QM, + start = list(21,4), + end = list(21,6), na.rm = FALSE, + time_dim = 'ftime', ncores = 6) +sprR_hcst_ref <- CST_PeriodAccumulation(hcst_ref, + start = list(21,4), + end = list(21,6), + time_dim = 'ftime', ncores = 6) +sprR_obs <- CST_PeriodAccumulation(obs, + start = list(21,4), + end = list(21,6), + time_dim = 'ftime', ncores = 6) +sprR_hcst <- CST_PeriodAccumulation(hcst_QM, + start = list(21,4), + end = list(21,6), + time_dim = 'ftime', ncores = 6) + +sprR_fcst$data <- MeanDims(sprR_fcst$data, c('lat', 'lon')) +sprR_hcst_ref$data <- MeanDims(sprR_hcst_ref$data, c('lat', 'lon')) +sprR_obs$data <- MeanDims(sprR_obs$data, c('lat', 'lon')) +sprR_hcst$data <- MeanDims(sprR_hcst$data, c('lat', 'lon')) + + +metric <- RPSS(sprR_hcst$data, obs = sprR_hcst_ref$data) + +terciles <- quantile(sprR_hcst$data, c(0.33, 0.66)) +extremes <- quantile(sprR_hcst$data, c(0.10, 0.90)) + +dim(sprR_fcst$data) <- c(member = 50, sdate = 1) +PlotForecastPDF(sprR_fcst$data, + tercile.limits = as.vector(terciles), + extreme.limits = extremes, + var.name = "sprR (mm)", + title = "Seasonal forecasts at West Iberian Peninsula", + fcst.names = paste("Start date: 2022-04-01\n fRPSS:", + round(metric$rpss, 3)), + obs = as.vector(sprR_obs$data), + plotfile = "sprR_PlotForecast_csindicators_2022.png") + + diff --git a/man/AbsToProbs.Rd b/man/AbsToProbs.Rd index 9b79296bfa5b152c6c75bbac08b05bf33828a1ac..7717c91e629da1345eb25df96f08054620776380 100644 --- a/man/AbsToProbs.Rd +++ b/man/AbsToProbs.Rd @@ -9,7 +9,7 @@ AbsToProbs( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", memb_dim = "member", sdate_dim = "sdate", ncores = NULL @@ -18,9 +18,11 @@ AbsToProbs( \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}{An optional parameter containing 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. All common dimensions with 'data' need to +have the same length.} \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 @@ -59,16 +61,19 @@ probabilities of each value in the ensemble. If multiple initializations 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)) +exp <- array(rnorm(216), dim = c(dataset = 1, member = 2, sdate = 3, + ftime = 9, lat = 2, lon = 2)) exp_probs <- AbsToProbs(exp) -data <- array(rnorm(5 * 2 * 61 * 1), - c(member = 5, sdate = 2, ftime = 61, lon = 1)) +data <- array(rnorm(5 * 3 * 61 * 1), + c(member = 5, sdate = 3, ftime = 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')) -exp_probs <- AbsToProbs(exp, start = list(21, 4), end = list(21, 6)) +dim(Dates) <- c(ftime = 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 e646dc627b325dece44c37eb14f72842f54998a8..172592c89c091e771f5a13f2084f594dc25b51e2 100644 --- a/man/AccumulationExceedingThreshold.Rd +++ b/man/AccumulationExceedingThreshold.Rd @@ -12,7 +12,7 @@ AccumulationExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", na.rm = FALSE, ncores = NULL ) @@ -20,44 +20,54 @@ AccumulationExceedingThreshold( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{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.} +\item{threshold}{If only one threshold is used: it can be a multidimensional +array with named dimensions. It must be in the same units and with the +common dimensions of the same length as parameter 'data'. It can also be a +vector with the same length of 'time_dim' from 'data' or a scalar. If we +want to use two thresholds: it can be a vector of two scalars, a list of +two vectors with the same length of 'time_dim' from 'data' or a list of +two multidimensional arrays with the common dimensions of the same length +as parameter 'data'. If two thresholds are used, parameter 'op' must be +also a vector of two elements.} -\item{op}{An operator '>' (by default), '<', '>=' or '<='.} +\item{op}{An operator '>' (by default), '<', '>=' or '<='. If two thresholds +are used it has to be a vector of a pair of two logical operators: +c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{diff}{A logical value indicating whether to accumulate the difference -between data and threshold (TRUE) or not (FALSE by default).} +\item{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.} -\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 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{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 +\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 +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 +\item{end}{An optional parameter to define 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 'ftime'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} +\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 +indicate one time dimension.} -\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or -not (FALSE).} +\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}. +aggregated values with dimensions of the input parameter 'data' except the +dimension where the indicator has been computed. } \description{ The accumulation (sum) of a variable in the days (or time steps) that the @@ -75,7 +85,7 @@ function: \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, time = 214, lon = 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"), diff --git a/man/CST_AbsToProbs.Rd b/man/CST_AbsToProbs.Rd index 57426efb6f4e7e88f6c3618c5e89a3db31f0e8fd..055bf6b571ad1fc82e1787e4805b6fe1743c89b8 100644 --- a/man/CST_AbsToProbs.Rd +++ b/man/CST_AbsToProbs.Rd @@ -61,12 +61,12 @@ 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)) -exp$Dates[[1]] <- 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_AbsToProbs(exp, start = list(21, 4), end = list(21, 6)) - +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) +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 9c0a521ae8bda6a57e102060bb91804bdaf496e6..bc0eb83f4d4d1b168b956c63facbbb6ea5de4fc4 100644 --- a/man/CST_AccumulationExceedingThreshold.Rd +++ b/man/CST_AccumulationExceedingThreshold.Rd @@ -17,42 +17,53 @@ CST_AccumulationExceedingThreshold( ) } \arguments{ -\item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in +\item{data}{An 's2dv_cube' object as provided by function \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 -'data' of the same length. A single scalar is also possible.} +\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 +same units and with the common dimensions of the same length as parameter +'data'. It can also be a vector with the same length of 'time_dim' from +'data' or a scalar. If we want to use two thresholds: it can be a vector +of two scalars, a list of two vectors with the same length of +'time_dim' from 'data' or a list of two multidimensional arrays with the +common dimensions of the same length as parameter 'data'. If two thresholds +are used, parameter 'op' must be also a vector of two elements.} -\item{op}{An operator '>' (by default), '<', '>=' or '<='.} +\item{op}{An operator '>' (by default), '<', '>=' or '<='. If two thresholds +are used it has to be a vector of a pair of two logical operators: +c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{diff}{A logical value indicating whether to accumulate the difference -between data and threshold (TRUE) or not (FALSE by default).} +\item{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.} -\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 +\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 +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 +\item{end}{An optional parameter to define 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 'ftime'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} +\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 +indicate one time dimension.} -\item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or -not (FALSE).} +\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 's2dv_cube' object containing the indicator in the element \code{data}. +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. } \description{ The accumulation (sum) of a variable in the days (or time steps) that the diff --git a/man/CST_MergeRefToExp.Rd b/man/CST_MergeRefToExp.Rd index a5b9cc76fa4e73595a865eac4998bc2c417b3772..9f9a3b977ce032bb44b6eb7724574738992e5d65 100644 --- a/man/CST_MergeRefToExp.Rd +++ b/man/CST_MergeRefToExp.Rd @@ -74,14 +74,14 @@ data_dates <- c(seq(as.Date("01-07-1993", "\%d-\%m-\%Y", tz = 'UTC'), dim(data_dates) <- c(ftime = 154, sdate = 2) data <- NULL data$data <- array(1:(2*154*2), c(ftime = 154, sdate = 2, member= 2)) -data$Dates$start <- data_dates +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) ref <- NULL ref$data <- array(1001:1700, c(ftime = 350, sdate = 2)) -ref$Dates$start <- ref_dates +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), diff --git a/man/CST_PeriodAccumulation.Rd b/man/CST_PeriodAccumulation.Rd index abc79b69cd51f8cce811885b0f17c134ce681187..39287052dc1e55d5bef9e24046e875bee38cdb73 100644 --- a/man/CST_PeriodAccumulation.Rd +++ b/man/CST_PeriodAccumulation.Rd @@ -62,17 +62,17 @@ 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$Dates[[1]] <- 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$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)) dim(SprR$data) -head(SprR$Dates) +head(SprR$attrs$Dates) HarR <- CST_PeriodAccumulation(exp, start = list(21, 8), end = list(21, 10)) dim(HarR$data) -head(HarR$Dates) +head(HarR$attrs$Dates) } diff --git a/man/CST_PeriodMean.Rd b/man/CST_PeriodMean.Rd index b9ae538ee38a6bdd51e03fa09e7be58925211964..b1004ad56896fe2aa943677debd1aeec1590888f 100644 --- a/man/CST_PeriodMean.Rd +++ b/man/CST_PeriodMean.Rd @@ -58,10 +58,10 @@ this function: exp <- NULL exp$data <- array(rnorm(45), dim = c(member = 7, ftime = 8)) class(exp) <- 's2dv_cube' -exp$Dates$start <- 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")) +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) } diff --git a/man/CST_QThreshold.Rd b/man/CST_QThreshold.Rd index 0edbcba89a4e3a3ff57c7c5b4d090f6859c38185..eda0fd1ced67dd2d87d4b6924f343e4e27304ea1 100644 --- a/man/CST_QThreshold.Rd +++ b/man/CST_QThreshold.Rd @@ -85,12 +85,12 @@ 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$Dates[[1]] <- 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$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) } diff --git a/man/CST_SelectPeriodOnData.Rd b/man/CST_SelectPeriodOnData.Rd index 6e041624af16a773bbfa7a32a6a06ca55aca3f60..22b2a9c2dee5baa668962d8ade5a6d0519810581 100644 --- a/man/CST_SelectPeriodOnData.Rd +++ b/man/CST_SelectPeriodOnData.Rd @@ -37,13 +37,13 @@ Auxiliary function to subset data for a specific period. exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), c(memb = 5, sdate = 3, ftime = 214, lon = 2)) -exp$Dates$start <- 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$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) 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 5d260e9cb656f205a5d67339b573fdfd1627285b..ffe06000d67a6c1371749a872a3d48d1d0dc4be8 100644 --- a/man/CST_Threshold.Rd +++ b/man/CST_Threshold.Rd @@ -68,12 +68,12 @@ threshold <- 0.9 exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2), c(member = 5, sdate = 3, ftime = 214, lon = 2)) -exp$Dates$start <- 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$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')) 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 847fed25a2a4a66c22b918f3e7c23b2ea84833b6..e2f7d26c15bd92c2ef82bcf21d250ce8aac514df 100644 --- a/man/CST_TotalSpellTimeExceedingThreshold.Rd +++ b/man/CST_TotalSpellTimeExceedingThreshold.Rd @@ -19,17 +19,24 @@ CST_TotalSpellTimeExceedingThreshold( \item{data}{An 's2dv_cube' object as provided by function \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 -'data' of the same length. A single scalar is also possible. If -\code{timd_dim} is in the dimension (with the same length as \code{data}), -the comparison will be done day by day.} +\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 +same units and with the common dimensions of the same length as parameter +'data'. It can also be a vector with the same length of 'time_dim' from +'data' or a scalar. If we want to use two thresholds: it can be a vector +of two scalars, a list of two vectors with the same length of +'time_dim' from 'data' or a list of two multidimensional arrays with the +common dimensions of the same length as parameter 'data'. If two thresholds +are used, parameter 'op' must be also a vector of two elements.} \item{spell}{A scalar indicating the minimum length of the spell.} -\item{op}{An operator '>' (by default), '<', '>=' or '<='.} +\item{op}{An operator '>' (by default), '<', '>=' or '<='. If two thresholds +are used it has to be a vector of a pair of two logical operators: +c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{start}{An optional parameter to defined the initial date of the period +\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 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 @@ -41,16 +48,15 @@ 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 -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} +compute the indicator. By default, it is set to 'ftime'. It can only +indicate one time dimension.} \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}. +An 's2dv_cube' object containing the number of days that are part of a +spell within a threshold in element \code{data}. } \description{ The number of days (when daily data is provided) that are part of a spell @@ -72,12 +78,12 @@ by using function \code{AbsToProbs}. See section @examples. exp <- NULL exp$data <- array(rnorm(5 * 3 * 214 * 2)*23, c(member = 5, sdate = 3, ftime = 214, lon = 2)) -exp$Dates$start <- 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$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')) class(exp) <- 's2dv_cube' TTSET <- CST_TotalSpellTimeExceedingThreshold(exp, threshold = 23, spell = 3) diff --git a/man/CST_TotalTimeExceedingThreshold.Rd b/man/CST_TotalTimeExceedingThreshold.Rd index bbd05e04b7091c524e7468a754644d5c21ba3e1b..b09ae53bb10e5b46fdd792a7d523bd70300c4462 100644 --- a/man/CST_TotalTimeExceedingThreshold.Rd +++ b/man/CST_TotalTimeExceedingThreshold.Rd @@ -19,29 +19,35 @@ CST_TotalTimeExceedingThreshold( \item{data}{An 's2dv_cube' object as provided by function \code{CST_Load} in package CSTools.} -\item{threshold}{An 's2dv_cube' object as output of a 'CST_' function in the -same units as parameter \code{data} and with the common dimensions of the -element \code{data} of the same length (e.g. an array with the same lengths -of longitude and latitude). A single scalar is also possible (for the case -of comparing all grid points with the same scalar).} +\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 +same units and with the common dimensions of the same length as parameter +'data'. It can also be a vector with the same length of 'time_dim' from +'data' or a scalar. If we want to use two thresholds: it can be a vector +of two scalars, a list of two vectors with the same length of +'time_dim' from 'data' or a list of two multidimensional arrays with the +common dimensions of the same length as parameter 'data'. If two thresholds +are used, parameter 'op' must be also a vector of two elements.} -\item{op}{An operator '>' (by default), '<', '>=' or '<='.} +\item{op}{An operator '>' (by default), '<', '>=' or '<='. If two thresholds +are used it has to be a vector of a pair of two logical operators: +c('<', '>'), c('<', '>='), c('<=', '>'), c('<=', '>='), c('>', '<'), +c('>', '<='), c('>=', '<'),c('>=', '<=')).} -\item{start}{An optional parameter to defined the initial date of the period +\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 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 +\item{end}{An optional parameter to define 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 'ftime'. 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 'ftime'. It can only +indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -50,17 +56,18 @@ not (FALSE).} computation.} } \value{ -An 's2dv_cube' object containing the indicator in the element -\code{data}. +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. } \description{ -The Total Time of a variable exceeding (or not) a Threshold returns the total -number of days (if the data provided is daily, or the corresponding units to -the data frequency provided) that a variable is exceeding a threshold during a -period. The threshold provided must be in the same units than the variable -units, i.e. to use a percentile as a scalar, -the function \code{AbsToProbs} or \code{QThreshold} may be needed (see -examples). Providing maximum temperature daily data, the following agriculture +The Total Time of a variable exceeding (or not) a Threshold. It returns the +total number of days (if the data provided is daily, or the corresponding +units of the data frequency) that a variable is exceeding a threshold +during a period. The threshold provided must be in the same units as the +variable units, i.e. to use a percentile as a scalar, the function +\code{AbsToProbs} or \code{QThreshold} may be needed (see examples). +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 @@ -78,12 +85,12 @@ indices for heat stress can be obtained by using this function: exp <- NULL exp$data <- array(abs(rnorm(5 * 3 * 214 * 2)*280), c(member = 5, sdate = 3, ftime = 214, lon = 2)) -exp$Dates$start <- 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$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')) class(exp) <- 's2dv_cube' DOT <- CST_TotalTimeExceedingThreshold(exp, threshold = 280) diff --git a/man/CST_WindCapacityFactor.Rd b/man/CST_WindCapacityFactor.Rd index 1dd879bebefc4f8675f0549a7f38ba8efc6d116c..638f5b858ff97d9dcc7302bfda05c49a5b921959 100644 --- a/man/CST_WindCapacityFactor.Rd +++ b/man/CST_WindCapacityFactor.Rd @@ -58,18 +58,22 @@ different power curves that span different IEC classes can be selected (see below). } \examples{ -wind <- array(rweibull(n = 100, shape = 2, scale = 6), c(member = 10, lat = 2, lon = 5)) -wind <- CSTools::s2dv_cube(data = wind, lat = c(40, 41), lon = 1:5, - Variable = list(varName = 'sfcWind', level = 'Surface'), - Datasets = 'synthetic', when = Sys.time(), - Dates = list(start = '1990-01-01 00:00:00', end = '1990-01-01 00:00:00'), - source_file = NA) +wind <- NULL +wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), + c(member = 10, lat = 2, lon = 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') +class(wind) <- 's2dv_cube' WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") } \references{ -Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, F. J. (2019). -Seasonal forecasts of wind power generation. Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 +Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, +F. J. (2019). Seasonal forecasts of wind power generation. +Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 International Standard IEC 61400-1 (third ed.) (2005) } diff --git a/man/CST_WindPowerDensity.Rd b/man/CST_WindPowerDensity.Rd index 9c3040cbd6adfc0ed2ab4c8b05087976c0775d0e..c33bd8d99a3cb0f0bb37e1872e962f1878ab7674 100644 --- a/man/CST_WindPowerDensity.Rd +++ b/man/CST_WindPowerDensity.Rd @@ -51,13 +51,16 @@ 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 <- array(rweibull(n = 100, shape = 2, scale = 6), c(member = 10, lat = 2, lon = 5)) -wind <- CSTools::s2dv_cube(data = wind, lat = c(40, 41), lon = 1:5, - Variable = list(varName = 'sfcWind', level = 'Surface'), - Datasets = 'synthetic', when = Sys.time(), - Dates = list(start = '1990-01-01 00:00:00', end = '1990-01-01 00:00:00'), - source_file = NA) -WPD <- CST_WindPowerDensity(wind) +wind <- NULL +wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), + c(member = 10, lat = 2, lon = 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') +class(wind) <- 's2dv_cube' +WCF <- CST_WindPowerDensity(wind) } \author{ diff --git a/man/MergeRefToExp.Rd b/man/MergeRefToExp.Rd index f5b4958adcef5cf0d37cec9f8d03fc621dd79113..e6b40c8c57fdff75e2e16ed51aa3c1d6c7d38d76 100644 --- a/man/MergeRefToExp.Rd +++ b/man/MergeRefToExp.Rd @@ -13,7 +13,7 @@ MergeRefToExp( dates2, start2, end2, - time_dim = "time", + time_dim = "ftime", sdate_dim = "sdate", ncores = NULL ) @@ -21,7 +21,7 @@ MergeRefToExp( \arguments{ \item{data1}{A multidimensional array with named dimensions.} -\item{dates1}{a vector of dates or a multidimensional array of dates with +\item{dates1}{A vector of dates or a multidimensional array of dates with named dimensions matching the dimensions on parameter 'data1'.} \item{start1}{A list to define the initial date of the period to select from @@ -48,7 +48,8 @@ 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.} +specified. This dimension is required 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.} @@ -80,6 +81,7 @@ ref <- array(1001:1700, c(time = 350, sdate = 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)) + start2 = list(1, 7), end = list(21, 9), + time_dim = 'time') } diff --git a/man/SelectPeriodOnData.Rd b/man/SelectPeriodOnData.Rd index 118cb98e2a1347e31bdb1603588c7ae5821767ea..caaa0fb290b86c2c91a7a5793c47865aa1b1982c 100644 --- a/man/SelectPeriodOnData.Rd +++ b/man/SelectPeriodOnData.Rd @@ -7,23 +7,25 @@ SelectPeriodOnData(data, dates, start, end, time_dim = "ftime", ncores = NULL) } \arguments{ -\item{data}{A multidimensional array with named dimensions.} +\item{data}{A multidimensional array with named dimensions with at least the +time dimension specified in parameter 'time_dim'. All common dimensions +with 'dates' parameter need to have the same length.} -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions.} +\item{dates}{An array of dates with named dimensions with at least the time +dimension specified in parameter 'time_dim'. All common dimensions with +'data' parameter need to have the same length.} -\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.} +\item{start}{A list with two elements to define the initial date of the period +to select from the data. The first element is the initial day of the period +and the second element is the initial month of the period.} -\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.} +\item{end}{A list with two elements to define the final date of the period +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'. More than one -dimension name matching the dimensions provided in the object -\code{data$data} can be specified.} +compute select the dates. By default, it is set to 'ftime'. Parameters +'data' and 'dates'} \item{ncores}{An integer indicating the number of cores to use in parallel computation.} @@ -47,5 +49,4 @@ Dates <- c(seq(as.Date("01-05-2000", format = "\%d-\%m-\%Y"), as.Date("30-11-2002", format = "\%d-\%m-\%Y"), by = 'day')) dim(Dates) <- c(ftime = 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 cce8e55d82776129dc3eda6f97d928534780869e..386fb92880f0e6119ed5b9d2c2d2f3ca701f35a3 100644 --- a/man/SelectPeriodOnDates.Rd +++ b/man/SelectPeriodOnDates.Rd @@ -7,8 +7,7 @@ SelectPeriodOnDates(dates, start, end, time_dim = "ftime", ncores = NULL) } \arguments{ -\item{dates}{A vector of dates or a multidimensional array of dates with named -dimensions.} +\item{dates}{An array of dates with named dimensions.} \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 @@ -40,5 +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) Period <- SelectPeriodOnDates(Dates, start = list(21, 6), end = list(21, 9)) } diff --git a/man/TotalSpellTimeExceedingThreshold.Rd b/man/TotalSpellTimeExceedingThreshold.Rd index 37fd6cc0999f4bcf793bfa8da81248aa3758e87a..276423bb14092674ee655377d78a89e3a9f8796a 100644 --- a/man/TotalSpellTimeExceedingThreshold.Rd +++ b/man/TotalSpellTimeExceedingThreshold.Rd @@ -12,21 +12,29 @@ TotalSpellTimeExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", ncores = NULL ) } \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{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. If \code{timd_dim} is in the dimension (with the -same length as \code{data}), the comparison will be done day by day.} +\item{threshold}{If only one threshold is used: it can be a multidimensional +array with named dimensions. It must be in the same units and with the +common dimensions of the same length as parameter 'data'. It can also be a +vector with the same length of 'time_dim' from 'data' or a scalar. If we +want to use two thresholds: it can be a vector of two scalars, a list of +two vectors with the same length of 'time_dim' from 'data' or a list of +two multidimensional arrays with the common dimensions of the same length +as parameter 'data'. If two thresholds are used, parameter 'op' must be +also a vector of two elements.} \item{spell}{A scalar indicating the minimum length of the spell.} -\item{op}{An operator '>' (by default), '<', '>=' or '<='.} +\item{op}{An operator '>' (by default), '<', '>=' or '<='. If two thresholds +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 @@ -38,22 +46,23 @@ 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 +\item{end}{An optional parameter to define 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 'ftime'. 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 'ftime'. It can only +indicate one time dimension.} \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}. +A multidimensional array with named dimensions containing the number +of days that are part of a spell within a threshold with dimensions of the +input parameter 'data' except the dimension where the indicator has been +computed. } \description{ The number of days (when daily data is provided) that are part of a spell @@ -77,7 +86,7 @@ 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, time = 20, lat = 4)) +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) diff --git a/man/TotalTimeExceedingThreshold.Rd b/man/TotalTimeExceedingThreshold.Rd index f874b50a3eac4e58a3d15ca287fe782c7e8c8176..206847574f25df8eabde09914d03bbd2d116bc46 100644 --- a/man/TotalTimeExceedingThreshold.Rd +++ b/man/TotalTimeExceedingThreshold.Rd @@ -11,7 +11,7 @@ TotalTimeExceedingThreshold( dates = NULL, start = NULL, end = NULL, - time_dim = "time", + time_dim = "ftime", na.rm = FALSE, ncores = NULL ) @@ -19,33 +19,39 @@ TotalTimeExceedingThreshold( \arguments{ \item{data}{A multidimensional array with named dimensions.} -\item{threshold}{A multidimensional array with named dimensions in the same -units as parameter \code{data} and with the common dimensions of the element -\code{data} of the same length (e.g. an array with the same lengths of -longitude and latitude). A single scalar is also possible (for the case of -comparing all grid points with the same scalar).} +\item{threshold}{If only one threshold is used: it can be a multidimensional +array with named dimensions. It must be in the same units and with the +common dimensions of the same length as parameter 'data'. It can also be a +vector with the same length of 'time_dim' from 'data' or a scalar. If we +want to use two thresholds: it can be a vector of two scalars, a list of +two vectors with the same length of 'time_dim' from 'data' or a list of +two multidimensional arrays with the common dimensions of the same length +as parameter 'data'. If two thresholds are used, parameter 'op' must be +also a vector of two elements.} -\item{op}{A operator '>' (by default), '<', '>=' or '<='.} +\item{op}{An operator '>' (by default), '<', '>=' or '<='. If two thresholds +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{start}{An optional parameter to defined the initial date of the period +\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 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 +\item{end}{An optional parameter to define 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.} +compute the indicator. By default, it is set to 'ftime'. It can only +indicate one time dimension.} \item{na.rm}{A logical value indicating whether to ignore NA values (TRUE) or not (FALSE).} @@ -54,21 +60,23 @@ not (FALSE).} computation.} } \value{ -A multidimensional array with named dimensions containing the -indicator in the element \code{data}. +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. } \description{ -The Total Time of a variable exceeding (or not) a Threshold returns the total -number of days (if the data provided is daily, or the corresponding units to -the data frequency provided) that a variable is exceeding a threshold during a -period. The threshold provided must be in the same units than the variable -units, i.e. to use a percentile as a threshold, the function \code{Threshold} -or \code{QThreshold} may be needed (see examples). Providing maximum -temperature daily data, the following agriculture indices for heat stress can -be obtained by using this function: +The Total Time of a variable exceeding (or not) a Threshold. It returns the +total number of days (if the data provided is daily, or the corresponding +units of the data frequency) that a variable is exceeding a threshold +during a period. The threshold provided must be in the same units as the +variable units, i.e. to use a percentile as a scalar, the function +\code{AbsToProbs} or \code{QThreshold} may be needed (see examples). +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} + 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 diff --git a/man/WindCapacityFactor.Rd b/man/WindCapacityFactor.Rd index 557771e864a523db0a335f2e8e5bdfc8eb282e5d..69549a817e3ebd951e3e47e553205699276f95ce 100644 --- a/man/WindCapacityFactor.Rd +++ b/man/WindCapacityFactor.Rd @@ -70,8 +70,9 @@ WCF <- WindCapacityFactor(wind, IEC_class = "III") } \references{ -Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, F. J. (2019). -Seasonal forecasts of wind power generation. Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 +Lledó, Ll., Torralba, V., Soret, A., Ramon, J., & Doblas-Reyes, +F. J. (2019). Seasonal forecasts of wind power generation. +Renewable Energy, 143, 91–100. https://doi.org/10.1016/j.renene.2019.04.135 International Standard IEC 61400-1 (third ed.) (2005) } diff --git a/tests/testthat/test-AbsToProbs.R b/tests/testthat/test-AbsToProbs.R index 9ef6df223f17b5e4e2e68ad8110f7d8a1141e725..902b3f11cfd7be18a2ee3d8338388baacac34e1d 100644 --- a/tests/testthat/test-AbsToProbs.R +++ b/tests/testthat/test-AbsToProbs.R @@ -1,28 +1,110 @@ -context("Generic tests") -test_that("Sanity checks", { - #source("csindicators/R/AbsToProbs.R") - expect_error(AbsToProbs('x'), "Parameter 'data' must be numeric.") - expect_equal(AbsToProbs(1), array(1, c(sdate = 1, member = 1))) - expect_equal(AbsToProbs(1, memb_dim = 'x'), array(1, c(sdate = 1, x = 1))) - expect_error(AbsToProbs(data = NULL), "Parameter 'data' cannot be NULL.") - expect_error(AbsToProbs(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(AbsToProbs(1:10), array(seq(0.1, 1, 0.1), c(sdate = 1, member = 10))) +context("CSIndicators::AbsToProbs tests") + +############################################## +# dat1 +dat1 <- NULL +dat1$data <- array(rnorm(5 * 2 * 61 * 1), + c(member = 5, sdate = 2, ftime = 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"), + as.Date("30-06-2001", format = "%d-%m-%Y"), by = 'day')) +dat1$attrs$Dates <- Dates1 +class(dat1) <- 's2dv_cube' +# dat2 +Dates2 <- Dates1 +dim(Dates2) <- c(ftime = 61, sdate = 2) +############################################## + +test_that("1. Sanity checks", { + # CST_AbsToProbs + expect_error( + CST_AbsToProbs('x'), + paste0("Parameter 'data' must be of the class 's2dv_cube'.") + ) + expect_warning( + CST_AbsToProbs(dat1, start = list(21, 4), end = list(21, 6)), + paste0("Dimensions in 'data' element 'attrs$Dates' are missed and ", + "all data would be used."), + fixed = TRUE + ) + # AbsToProbs + expect_error( + AbsToProbs('x'), + "Parameter 'data' must be numeric." + ) + expect_warning( + AbsToProbs(1:10, start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'data' doesn't have dimension names and all ", + "data will be used.") + ) + expect_error( + AbsToProbs(dat1$data, start = c(21, 4), end = c(21, 6)), + paste0("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + ) + expect_warning( + AbsToProbs(dat1$data, start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'dates' is not provided and all data will be used.") + ) + expect_warning( + AbsToProbs(data = dat1$data, dates = Dates1, + start = list(21, 4), end = list(21, 6)), + paste0("Parameter 'dates' doesn't have dimension names and all data will be used.") + ) + 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) + ) + expect_equal( + AbsToProbs(1), + 1 + ) + expect_equal( + AbsToProbs(1:10), + seq(0.1, 1.0, 0.1) + ) + expect_equal( + AbsToProbs(1, memb_dim = 'x'), + 1 + ) + expect_error( + AbsToProbs(data = NULL), + "Parameter 'data' must be numeric." + ) data <- array(1:24, c(member = 3, sdate = 2, lon = 4)) - expect_equal(AbsToProbs(data), array(rep(0:1,12), c(sdate = 2, member = 3, lon = 4))) + expect_equal( + AbsToProbs(data), + array(c(rep(0, 3), rep(1, 3)), c(member = 3, sdate = 2, lon = 4)) + ) }) -test_that("Seasonal forecasts", { +############################################## +library(CSTools) +library(s2dv) - exp <- CSTools::lonlat_data$exp$data[1,1:3,1:3,,1:5,1:5] +test_that("2. Seasonal forecasts", { + exp <- CSTools::lonlat_temp$exp$data[1,1:3,1:3,,1:5,1:5] exp_probs <- AbsToProbs(exp) - expect_equal(dim(exp)[3:5], dim(exp_probs)[3:5]) - expect_equal(round(exp_probs[,1,1,1,1]), c(1, 0, 1)) + expect_equal( + dim(exp)[3:5], + dim(exp_probs)[3:5] + ) + expect_equal( + round(exp_probs[1,,1,1,1]), + c(1, 0, 1) + ) exp <- exp[,1,,,] # one sdate - expect_error(exp1_probs <- AbsToProbs(exp), - "Could not find dimension 'sdate' in 1th object provided in 'data'.") - library(s2dv) + expect_error( + exp1_probs <- AbsToProbs(exp), + "Could not find dimension 'sdate' in 1th object provided in 'data'." + ) + exp1 <- InsertDim(exp, 2, 1, name = 'sdate') exp1_probs <- AbsToProbs(exp1) - expect_equal(round(exp1_probs[1,,2,2,2]), c(1, 0, 1)) + expect_equal( + round(exp1_probs[,1,2,2,2]), + c(1, 0, 1) + ) }) diff --git a/tests/testthat/test-AccumulationExceedingThreshold.R b/tests/testthat/test-AccumulationExceedingThreshold.R index 90056b90a3ade8f50a1b3ca9a0a035adbbe461d7..a6b598e79df666b4b11e1d3e6c6cd09e3c895d90 100644 --- a/tests/testthat/test-AccumulationExceedingThreshold.R +++ b/tests/testthat/test-AccumulationExceedingThreshold.R @@ -1,100 +1,307 @@ -context("Generic tests") -test_that("Sanity checks", { - #source("csindicators/R/AccumulationExceedingThreshold.R") - expect_error(AccumulationExceedingThreshold(NULL), - "Parameter 'data' cannot be NULL.") - expect_error(AccumulationExceedingThreshold('x'), - "Parameter 'data' must be numeric.") - data <- 1:20 - expect_error(AccumulationExceedingThreshold(data, NULL), - "Parameter 'threshold' cannot be NULL.") - expect_error(AccumulationExceedingThreshold(data, 'x'), - "Parameter 'threshold' must be numeric.") - threshold <- 10 - expect_equal(AccumulationExceedingThreshold(data, threshold), 155) - dim(data) <- c(2, 10) - expect_error(AccumulationExceedingThreshold(data, threshold), - "Parameter 'data' must have named dimensions.") - names(dim(data)) <- c('lat', 'time') - threshold <- array(1:2, 2) - expect_error(AccumulationExceedingThreshold(data, threshold), - "Parameter 'threshold' must have named dimensions.") - dim(threshold) <- c(time = 2) - data <- array(1:40, c(x = 2, ftime = 20)) - expect_error(AccumulationExceedingThreshold(data, threshold), - "Could not find dimension 'time' in 1th object provided in 'data'.") - threshold <- 10 - expect_equal(AccumulationExceedingThreshold(data, threshold, time_dim = 'ftime'), - array(c(375, 390), c(x = 2))) - dim(threshold) <- c(member = 1, ftime = 1) - expect_equal(AccumulationExceedingThreshold(data, threshold, time_dim = 'ftime'), - array(c(375, 390), c(x = 2))) - expect_equal(AccumulationExceedingThreshold(data, threshold, time_dim = 'x'), - array(c(rep(0,5), seq(23, 79, 4)), c(ftime = 20))) - expect_error(AccumulationExceedingThreshold(data, threshold, - time_dim = 'x', ncores = 'Z'), - "Parameter 'ncores' must be numeric") - - expect_equal(AccumulationExceedingThreshold(data, threshold, time_dim = 2), - array(c(375, 390), c(x = 2))) - # dimensions: - data <- array(1:20, c(time = 5, sdate = 2, lat = 2)) - # does this case made sense? - threshold <- array(1:5, c(time = 5)) - expect_equal(dim(AccumulationExceedingThreshold(data, threshold)), - c(sdate = 2, lat = 2)) - threshold <- array(1:2, c(lat = 2)) - expect_equal(dim(AccumulationExceedingThreshold(data, threshold)), - c(sdate = 2, lat = 2)) - data <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) - expect_equal(dim(AccumulationExceedingThreshold(data, threshold, - time_dim = c('time', 'fyear'))), - c(sdate = 2, lat = 2)) +context("CSIndicators::AccumulationExceedingThreshold tests") + +# 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)) +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)) + +# dat4 +set.seed(1) +dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +set.seed(1) +thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +set.seed(2) +thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +set.seed(1) +thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +set.seed(2) +thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +set.seed(1) +thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +set.seed(2) +thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +set.seed(1) +thres4_7 <- rnorm(5, 20) +set.seed(2) +thres4_8 <- rnorm(5, 25) + +############################################## +test_that("1. Input checks", { + # data + expect_error( + AccumulationExceedingThreshold(NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + AccumulationExceedingThreshold('x'), + "Parameter 'data' must be numeric." + ) + expect_error( + AccumulationExceedingThreshold(array(dat1, dim = c(2, 10)), 10), + "Parameter 'data' must have named dimensions." + ) + # time_dim + expect_error( + AccumulationExceedingThreshold(dat1, 10, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + AccumulationExceedingThreshold(array(dat1, dim = c('sdate' = 20)), 10), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # op + expect_error( + AccumulationExceedingThreshold(dat1, 10, op = 1), + "Parameter 'op' must be a character." + ) + expect_error( + AccumulationExceedingThreshold(dat1, 10, op = 'a'), + "Parameter 'op' must be a logical operator." + ) + expect_error( + AccumulationExceedingThreshold(dat1, 10, op = c('=','=')), + "Parameter 'op' is not an accepted pair of logical operators." + ) + expect_error( + AccumulationExceedingThreshold(dat1, 10, op = c('=','<','>')), + "Parameter 'op' must be a logical operator with length 1 or 2." + ) + # threshold + expect_error( + AccumulationExceedingThreshold(dat1, NULL), + "Parameter 'threshold' cannot be NULL." + ) + expect_error( + AccumulationExceedingThreshold(dat1, 'x'), + "Parameter 'threshold' must be numeric." + ) + expect_error( + AccumulationExceedingThreshold(dat1, 10, op = c("<",">")), + "If 'op' is a pair of logical operators parameter 'threshold' also has to be a pair of values." + ) + expect_error( + AccumulationExceedingThreshold(dat1, list(1:10,1:20), op = c("<",">")), + "The pair of thresholds must have the same length." + ) + expect_error( + AccumulationExceedingThreshold(dat1, list(array(1:10, c(lat = 2, lon = 5)),array(1:10, c(time = 5, lon = 2))), op = c("<",">")), + "The pair of thresholds must have the same dimension names." + ) + expect_error( + AccumulationExceedingThreshold(dat1, list(array(1:10, c(lat = 2, lon = 5)),array(1:10, c(time = 2, lon = 5))), op = c("<",">")), + "The pair of thresholds must have the same dimension names." + ) + expect_error( + AccumulationExceedingThreshold(dat1, list(array(1:10, c(time = 2)),array(1:10, c(time = 2))), op = c("<",">"), time_dim = 'time'), + "Parameter 'data' and 'threshold' must have same length of all common dimensions." + ) + expect_error( + AccumulationExceedingThreshold(dat1, 1:10, op = "<"), + "If parameter 'threshold' is a vector it must have the same length as data time dimension." + ) + expect_error( + AccumulationExceedingThreshold(dat1, array(rnorm(10)), op = "<"), + "If parameter 'threshold' is an array it must have named dimensions." + ) + expect_error( + AccumulationExceedingThreshold(dat1, array(20, dim = c(time = 2)), op = "<", time_dim = 'time'), + "Parameter 'data' and 'threshold' must have same length of all common dimensions." + ) + # ncores + expect_error( + AccumulationExceedingThreshold(dat1, 10, time_dim = 'x', ncores = 1.5), + "Parameter 'ncores' must be a positive integer." + ) + # dates + expect_error( + AccumulationExceedingThreshold(dat1, 10, op = "<", dates = 2, start = 'a', end = 'b'), + paste0("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + ) + # diff + expect_error( + AccumulationExceedingThreshold(dat2_3, thres2_3, diff = T), + paste0("Parameter 'diff' can't be TRUE if the parameter 'threshold' is not a scalar.") + ) +}) + +############################################## +test_that("2. Output checks", { + expect_equal( + AccumulationExceedingThreshold(dat1, 10), + 155 + ) + expect_equal( + AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'ftime'), + array(c(375, 390), c(x = 2)) + ) + expect_equal( + AccumulationExceedingThreshold(dat2_1, thres2_1, time_dim = 'ftime'), + 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)) + ) + expect_equal( + AccumulationExceedingThreshold(dat2_1, 10, time_dim = 'ftime'), + array(c(375, 390), c(x = 2)) + ) + # dimensions + expect_equal( + dim(AccumulationExceedingThreshold(dat2_3, thres2_3)), + c(sdate = 2, lat = 2) + ) + expect_equal( + dim(AccumulationExceedingThreshold(dat2_3, thres2_4)), + c(sdate = 2, lat = 2) + ) + expect_equal( + dim(AccumulationExceedingThreshold(dat2_4, thres2_4, time_dim = 'ftime')), + c(fyear = 3, sdate = 2, lat = 2) + ) + +}) + +############################################## +test_that("3. Output checks", { + + expect_equal( + dim(AccumulationExceedingThreshold(dat3_1, c(55,58), c('<', '>'))), + c(fyear = 3, sdate = 2, lat = 2) + ) + expect_equal( + AccumulationExceedingThreshold(dat3_1, c(55,58), c(">", "<")), + array(c(rep(0,11),113), dim = c(fyear = 3, sdate = 2, lat = 2)) + ) + expect_equal( + AccumulationExceedingThreshold(dat3_1, c(55,58), c(">=", "<=")), + 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'), + array(c(76, 114), c(x = 2)) + ) + expect_equal( + AccumulationExceedingThreshold(dat3_2, c(7,11), op = c('>=', '<='), time_dim = 'ftime'), + array(c(27, 18), c(x = 2)) + ) + expect_equal( + dim(AccumulationExceedingThreshold(dat2_3, list(thres2_4, thres2_4+1), op = c('>=', '<'))), + c(sdate = 2, lat = 2) + ) }) -test_that("Seasonal forecasts", { +############################################## + +test_that("4. Output checks", { + + expect_equal( + dim(AccumulationExceedingThreshold(dat4, list(thres4_2, thres4_1), c('<=', '>'))), + c(fyear = 3, sdate = 2, lat = 2) + ) + expect_equal( + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_1, thres4_2), c(">", "<="))[1:3]), + c(91.05107, 115.67568, 69.89353), + tolerance = 0.0001 + ) + expect_equal( + as.vector(AccumulationExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'ftime'))[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], + 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], + c(117.29783, 94.39550, 113.25711, 90.85402, 91.89458, 115.14699, 116.19438), + tolerance = 0.0001 + ) + +}) + +############################################## +library(CSTools) + +test_that("5. Seasonal forecasts", { + exp <- CSTools::lonlat_temp$exp + exp$data <- exp$data[ , 1:4, 1:2, , , ] + res <- CST_AccumulationExceedingThreshold(exp, threshold = 280, time_dim = 'ftime') + + expect_equal( + round(res$data[, 2, 2, 2]), + c(0, 280, 281, 281) + ) - exp <- CSTools::lonlat_data$exp - exp$data <- exp$data[,1:4,1:2,,,] - res <- CST_AccumulationExceedingThreshold(exp, threshold = 280) - expect_equal(round(res$data[,2,2,2]), - c(0, 280, 281, 281)) # 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, ftime = 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 - exp[,,125:155,,] <- exp1 + 14; exp[,,156:186,,] <- exp1 + 15 - exp[,,187:214,,] <- exp1[,,1:28,,] + 16 + exp[, , 1:31, , ] <- exp1 + 10; exp[, , 32:62, , ] <- exp1 + 11 + exp[, , 63:93, , ] <- exp1 + 12; exp[, , 94:124, , ] <- exp1 + 13 + exp[, , 125:155, , ] <- exp1 + 14; exp[, , 156:186, , ] <- exp1 + 15 + exp[, , 187:214, , ] <- exp1[, , 1:28, , ] + 16 + 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')) + 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')) GDD <- AccumulationExceedingThreshold(exp - 17, threshold = 0, dates = Dates, time_dim = 'ftime', start = list(1, 4), end = list(31, 10), na.rm = TRUE) - expect_equal(round(GDD[,1,1,1]), - c(538, 372, 116, 525, 220, 330)) - expect_equal(dim(GDD), - 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)), - "Could not find dimension 'time' in 1th object provided in 'data'.") - 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)))) + + expect_equal( + round(GDD[,1,1,1]), + c(538, 367, 116, 519, 219, 282) + ) + expect_equal( + dim(GDD), + 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'), + "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))) + ) # test the 'diff' - input <- c(1:20) - threshold <- 3 - expect_equal(AccumulationExceedingThreshold(input, threshold, diff = TRUE), - 153) - expect_equal(AccumulationExceedingThreshold(input, threshold), - 204) - input1 <- -input[1:15] - threshold <- -5 - expect_equal(AccumulationExceedingThreshold(input1, threshold, op = '<'), - -105) - expect_equal(AccumulationExceedingThreshold(input1, threshold, op = '<', diff = TRUE), - -55) + input_1 <- c(1:20) + threshold_1 <- 3 + input_2 <- -input_1[1:15] + threshold_2 <- -5 + + expect_equal( + AccumulationExceedingThreshold(input_1, threshold_1, diff = TRUE), + 153 + ) + expect_equal( + AccumulationExceedingThreshold(input_1, threshold_1), + 204 + ) + + expect_equal( + AccumulationExceedingThreshold(input_2, threshold_2, op = '<'), + -105 + ) + expect_equal( + AccumulationExceedingThreshold(input_2, threshold_2, op = '<', diff = TRUE), + -55 + ) }) diff --git a/tests/testthat/test-MergeRefToExp.R b/tests/testthat/test-MergeRefToExp.R index b4503d86f34abf8c1348f4dafc7cd82dedc32d46..2c3e8f65637be858ef835dd10ba07e9e4a871938 100644 --- a/tests/testthat/test-MergeRefToExp.R +++ b/tests/testthat/test-MergeRefToExp.R @@ -1,6 +1,8 @@ -context("Generic tests") +context("CSIndicators::MergeRefToExp tests") + +########################################################################### + test_that("Sanity checks", { - #source("csindicators/R/MergeRefToExp.R") 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'), @@ -10,33 +12,31 @@ test_that("Sanity checks", { 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) - ref <- array(1001:1700, c(ftime = 350, sdate = 2)) - data <- array(1:(2 * 154 * 2), c(ftime = 154, sdate = 2, member= 2)) + ref <- NULL + ref$data <- array(1001:1700, c(ftime = 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$attrs$Dates <- data_dates + class(data) <- 's2dv_cube' -suppressWarnings( - ref <- CSTools::s2dv_cube(data = ref, Dates = list(start = ref_dates, - end = ref_dates)) -) -suppressWarnings( - data <- CSTools::s2dv_cube(data = data, Dates = list(start = data_dates, - end = data_dates)) -) 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))$Dates, + 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)) -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), + 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) -) + # issue 13: One lead time data_dates <- c(as.Date("01-06-1993", "%d-%m-%Y", tz = 'UTC'), @@ -48,17 +48,15 @@ suppressWarnings( 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) - ref <- array(1:2, c(ftime = 1, sdate = 2)) - data <- array(1:(2 * 3 * 2), c(ftime = 2, sdate = 2, member = 3)) + ref <- NULL + ref$data <- array(1:2, c(ftime = 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$attrs$Dates <- data_dates + class(data) <- 's2dv_cube' -suppressWarnings( - ref <- CSTools::s2dv_cube(data = ref, Dates = list(start = ref_dates, - end = ref_dates)) -) -suppressWarnings( - data <- CSTools::s2dv_cube(data = data, Dates = list(start = data_dates, - end = data_dates)) -) res_dates <- c(as.Date("01-05-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-06-1993", "%d-%m-%Y", tz = 'UTC'), as.Date("01-07-1993", "%d-%m-%Y", tz = 'UTC'), @@ -67,23 +65,24 @@ suppressWarnings( as.Date("01-07-1994","%d-%m-%Y", tz = 'UTC')) dim(res_dates) <- c(ftime = 3, sdate = 2) -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), + + expect_equal( + CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), end1 = list(31, 5), start2 = list(1, 6), - end2 = list(31, 7))$Dates, - res_dates) -) + end2 = list(31, 7))$attrs$Dates, + res_dates + ) 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') -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), + expect_equal( + CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(1, 5), end1 = list(31, 5), start2 = list(1, 6), end2 = list(31, 7))$data, - output) -) + output + ) }) @@ -103,34 +102,26 @@ test_that("Seasonal", { dim.dates <- c(ftime=215, sweek = 1, sday = 1, sdate=(hcst.endyear-hcst.inityear)+1) dim(dates) <- dim.dates - - ref <- array(1:(215*25), c(ftime = 215, sdate = 25)) - -suppressWarnings( - ref <- CSTools::s2dv_cube(data = ref, - Dates = list(start = dates, - end = dates)) -) - - data <- array(1:(215*25*3), c(ftime = 215, sdate = 25, member=3)) - -suppressWarnings( - data <- CSTools::s2dv_cube(data = data, - Dates = list(start = dates, - end = dates)) -) - -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = data, data2 = ref, start1 = list(21, 6), - end1 = list(30, 6), start2 = list(1, 7), - end2 = list(21, 9))$Dates, - SelectPeriodOnDates(dates, start = list(21, 6), end = list(21,9))) -) + ref <- NULL + ref$data <- array(1:(215*25), c(ftime = 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$attrs$Dates <- dates + class(data) <- 's2dv_cube' + + expect_equal( + CST_MergeRefToExp(data1 = data, data2 = ref, start1 = list(21, 6), + end1 = list(30, 6), start2 = list(1, 7), + end2 = list(21, 9))$attrs$Dates, + SelectPeriodOnDates(dates, start = list(21, 6), end = list(21,9)) + ) -suppressWarnings( - expect_equal(CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), + expect_equal( + CST_MergeRefToExp(data1 = ref, data2 = data, start1 = list(21, 6), end1 = list(30, 6), start2 = list(1, 7), - end2 = list(21, 9))$Dates, - SelectPeriodOnDates(dates, start = list(21, 6), end = list(21,9))) -) + end2 = list(21, 9))$attrs$Dates, + SelectPeriodOnDates(dates, start = list(21, 6), end = list(21,9)) + ) }) diff --git a/tests/testthat/test-PeriodAccumulation.R b/tests/testthat/test-PeriodAccumulation.R index 0cd69a9393ee65c10c058891b6e1943288eeb9c0..777dc30cbe09cb21109d1d9506a2922563d8127f 100644 --- a/tests/testthat/test-PeriodAccumulation.R +++ b/tests/testthat/test-PeriodAccumulation.R @@ -1,40 +1,61 @@ -context("Generic tests") +context("CSIndicators::PeriodAccumulation tests") + test_that("Sanity Checks", { - #source("csindicators/R/PeriodAccumulation.R") - expect_error(PeriodAccumulation('x'), "Parameter 'data' must be numeric.") - expect_equal(PeriodAccumulation(1), 1) - expect_equal(PeriodAccumulation(1, time_dim = 'x'), 1) - expect_error(PeriodAccumulation(data = NULL), - "Parameter 'data' cannot be NULL.") - expect_error(PeriodAccumulation(1, dates = '2000-01-01', end = 3, start = 4), + expect_error( + PeriodAccumulation('x'), + "Parameter 'data' must be numeric." + ) + expect_equal( + PeriodAccumulation(1), + 1 + ) + expect_equal( + PeriodAccumulation(1, time_dim = 'x'), + 1 + ) + expect_error( + PeriodAccumulation(data = NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + PeriodAccumulation(1, 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.")) - expect_equal(PeriodAccumulation(1:10), 55) + "the day and the month of the period start and end.") + ) + expect_equal( + PeriodAccumulation(1:10), + 55 + ) data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) - expect_equal(PeriodAccumulation(data), - array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4))) + expect_equal( + PeriodAccumulation(data), + array(c(9, 12, 27, 30, 45, 48, 63, 66), c(sdate = 2, lon = 4)) + ) }) +############################################## +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$Dates[[1]] <- 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')) - + 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) 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]), sum(exp$data[1,2,21:82,2]), sum(exp$data[1,3,21:82,2])), c(memb = 1, sdate = 3, lon = 2)) - expect_equal(CST_PeriodAccumulation(exp, start = list(21, 4), - end = list(21, 6))$data, output$data) - + expect_equal( + CST_PeriodAccumulation(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) }) diff --git a/tests/testthat/test-PeriodMean.R b/tests/testthat/test-PeriodMean.R index 75b6d576550eef3e1aed99a9e025490efbf28b84..7576b1139ea2d05a7dbf2487012f99ac75e51712 100644 --- a/tests/testthat/test-PeriodMean.R +++ b/tests/testthat/test-PeriodMean.R @@ -1,44 +1,61 @@ -context("Generic tests") +context("CSIndicators::PeriodMean tests") + test_that("Sanity Checks", { - #source("csindicators/R/PeriodMean.R") - expect_error(PeriodMean('x'), "Parameter 'data' must be numeric.") + expect_error( + PeriodMean('x'), + "Parameter 'data' must be numeric." + ) suppressWarnings( - expect_equal(PeriodMean(array(1, c(x = 1)), time_dim = 'x'), 1) + expect_equal( + PeriodMean(array(1, c(x = 1)), time_dim = 'x'), + 1 + ) + ) + expect_error( + PeriodMean(data = NULL), + "Parameter 'data' cannot be NULL." ) - - expect_error(PeriodMean(data = NULL), "Parameter 'data' cannot be NULL.") - expect_error(PeriodMean(1, dates = '2000-01-01', end = 3, start = 4), + 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.") suppressWarnings( - expect_equal(PeriodMean(array(1:10, c(time = 10))), 5.5) + expect_equal( + PeriodMean(array(1:10, c(time = 10))), + 5.5 + ) ) data <- array(1:24, c(sdate = 2, time = 3, lon = 4)) suppressWarnings( - expect_equal(PeriodMean(data), - array(c(3,4,9,10,15,16,21,22), c(sdate = 2, lon = 4))) + expect_equal( + PeriodMean(data), + array(c(3, 4, 9, 10, 15, 16, 21, 22), + c(sdate = 2, lon = 4)) + ) ) }) -test_that("seasonal", { +############################################## +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$Dates[[1]] <- 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')) + 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) 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]), mean(exp$data[1,2,21:82,2]), mean(exp$data[1,3,21:82,2])), c(memb = 1, sdate = 3, lon = 2)) expect_equal( - CST_PeriodMean(exp, start = list(21, 4), end = list(21, 6))$data, - output$data) - - - + CST_PeriodMean(exp, start = list(21, 4), end = list(21, 6))$data, + output$data + ) }) diff --git a/tests/testthat/test-QThreshold.R b/tests/testthat/test-QThreshold.R index 14fd5d1892d35e6a3a29b1ad29a76b8a2cfad4c2..7572bd065e95930e3e427db62fde411e519362d1 100644 --- a/tests/testthat/test-QThreshold.R +++ b/tests/testthat/test-QThreshold.R @@ -1,77 +1,126 @@ -context("Generic tests") +context("CSIndicators::QThreshold tests") + test_that("Sanity checks", { - #source("csindicators/R/QThreshold.R") - expect_error(QThreshold(NULL), - "Parameter 'data' cannot be NULL.") - expect_error(QThreshold('x'), - "Parameter 'data' must be numeric.") + expect_error( + QThreshold(NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + QThreshold('x'), + "Parameter 'data' must be numeric." + ) data <- 1:20 - expect_error(QThreshold(data, NULL), - "Parameter 'threshold' cannot be NULL.") - expect_error(QThreshold(data, 'x'), - "Parameter 'threshold' must be numeric.") + expect_error( + QThreshold(data, NULL), + "Parameter 'threshold' cannot be NULL." + ) + expect_error( + QThreshold(data, 'x'), + "Parameter 'threshold' must be numeric." + ) threshold <- 10 - expect_error(QThreshold(data, threshold), - "'x' must have 1 or more non-missing values") + expect_error( + QThreshold(data, threshold), + "'x' must have 1 or more non-missing values" + ) dim(data) <- c(2, 10) - expect_error(QThreshold(data, threshold), - "Parameter 'data' must have named dimensions.") + expect_error( + QThreshold(data, threshold), + "Parameter 'data' must have named dimensions." + ) names(dim(data)) <- c('lat', 'sdate') threshold <- array(1:2, 2) - expect_error(QThreshold(data, threshold), - "Parameter 'threshold' must have named dimensions.") + expect_error( + QThreshold(data, threshold), + "Parameter 'threshold' must have named dimensions." + ) dim(threshold) <- c(time = 2) - data <- array(1:40, c(x = 2, sdate = 20)) threshold <- 10 - expect_equal(dim(QThreshold(data, threshold)), c(sdate = 20, x = 2)) + expect_equal( + dim(QThreshold(data, threshold)), + c(sdate = 20, x = 2) + ) data <- array(1:40, c(x = 2, ftime = 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)) + 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(threshold) <- c(member = 1, ftime = 1) - expect_equal(dim(QThreshold(data, threshold, sdate_dim = 'ftime')), - c(ftime = 20, x = 2)) - expect_equal(dim(QThreshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), - c(ftime = 20, x = 2)) - expect_error(QThreshold(data, threshold, - sdate_dim = 'x', ncores = 'Z'), - "Parameter 'ncores' must be numeric") + expect_equal( + dim(QThreshold(data, threshold, sdate_dim = 'ftime')), + c(ftime = 20, x = 2) + ) + expect_equal( + dim(QThreshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), + c(ftime = 20, x = 2) + ) + expect_error( + QThreshold(data, threshold, sdate_dim = 'x', ncores = 'Z'), + "Parameter 'ncores' must be numeric" + ) # dimensions: data <- array(1:20, c(time = 5, sdate = 2, lat = 2)) # does this case made sense? threshold <- array(1:5, c(time = 5)) - expect_equal(dim(QThreshold(data, threshold)), - c(sdate = 2, time = 5, lat = 2)) + expect_equal( + dim(QThreshold(data, threshold)), + c(sdate = 2, time = 5, lat = 2) + ) threshold <- array(1:2, c(lat = 2)) - expect_equal(dim(QThreshold(data, threshold)), - c(sdate = 2, time = 5, lat = 2)) + expect_equal( + dim(QThreshold(data, threshold)), + c(sdate = 2, time = 5, lat = 2) + ) data <- array(1:60, c(time = 5, member = 3, sdate = 2, lat = 2)) - expect_equal(dim(QThreshold(data, threshold)), - c(sdate = 2, member = 3, time = 5, lat = 2)) - expect_equal(dim(QThreshold(data, threshold, memb_dim = NULL)), - c(sdate = 2, time = 5, member = 3, lat = 2)) + expect_equal( + dim(QThreshold(data, threshold)), + c(sdate = 2, member = 3, time = 5, lat = 2) + ) + expect_equal( + dim(QThreshold(data, threshold, memb_dim = NULL)), + c(sdate = 2, time = 5, member = 3, lat = 2) + ) }) -test_that("Seasonal forecasts", { +############################################## +library(CSTools) - obs <- CSTools::lonlat_data$obs$data - 248 +test_that("Seasonal forecasts", { + obs <- CSTools::lonlat_temp$obs$data - 248 obs_percentile <- QThreshold(obs, threshold = 35) - expect_equal(dim(obs)[4:6], dim(obs_percentile)[4:6]) - expect_equal(obs_percentile[, 1, 1, 3, 20, 53], c(rep(0.4, 4), rep(0.2, 2))) + expect_equal( + dim(obs)[4:6], + dim(obs_percentile)[4:6] + ) + expect_equal( + obs_percentile[, 1, 1, 3, 20, 53], + c(rep(0.4, 4), rep(0.2, 2)) + ) obs1 <- obs[,,2,,,] # no sdate - expect_error(obs1_percentile <- QThreshold(obs1, threshold = 35), - "Could not find dimension 'sdate' in 1th object provided in 'data'.") - library(s2dv) - obs1 <- InsertDim(obs1, 1, 1, name = 'sdate') # one sdate - expect_error(obs1_percentile <- QThreshold(obs1, threshold = 35), - "'x' must have 1 or more non-missing values") + expect_error( + obs1_percentile <- QThreshold(obs1, threshold = 35), + "Could not find dimension 'sdate' in 1th object provided in 'data'." + ) + obs1 <- s2dv::InsertDim(obs1, 1, 1, name = 'sdate') # one sdate + expect_error( + obs1_percentile <- QThreshold(obs1, threshold = 35), + "'x' must have 1 or more non-missing values" + ) obs2 <- obs[,,,2,,] # one ftime obs2_percentile <- QThreshold(obs2, threshold = 35) - expect_equal(dim(obs2), dim(obs2_percentile)) - expect_equal(obs2_percentile[,14,53], c(0.6, 0.4, 0.6, 0.6, 0.4, 0.4)) - + expect_equal( + dim(obs2), + dim(obs2_percentile) + ) + expect_equal( + obs2_percentile[,14,53], + 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 3db72d862f8900141d25209015a37b6da29477f6..1c264c2b2ef5f88a85fb2ddac70f77908efd9ff9 100644 --- a/tests/testthat/test-SelectPeriod.R +++ b/tests/testthat/test-SelectPeriod.R @@ -1,37 +1,71 @@ -context("Generic tests") - #source("R/zzz.R") - #source("R/SelectPeriodOnDates.R") - #source("R/SelectPeriodOnData.R") - library(s2dv) -test_that("Sanity checks", { - #source("csindicators/R/AbsToProbs.R") +context("CSIndicators::SelectPeriodOnData and SelectPeriodOnDates tests") + +library(s2dv) + +############################################## + +test_that("1. Sanity checks", { + expect_error( + CST_SelectPeriodOnData(1:10), + paste0("Parameter 'data' must be of the class 's2dv_cube'.") + ) expect_error(SelectPeriodOnDates('x', start = list(1,1), end = list(1,1)), "invalid 'trim' argument") +}) + +############################################## + +test_that("2. Output checks", { # Lluis issue #8: dates <- c(seq(as.Date("02-05-1993", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), - seq(as.Date("02-05-1994", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day"), - seq(as.Date("02-05-1995", "%d-%m-%Y", tz = 'UTC'), - as.Date("01-12-1995","%d-%m-%Y", tz = 'UTC'), "day")) + as.Date("01-12-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("02-05-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("01-12-1994","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("02-05-1995", "%d-%m-%Y", tz = 'UTC'), + as.Date("01-12-1995","%d-%m-%Y", tz = 'UTC'), "day")) dim(dates) <- c(time = 214, file_date = 3) output <- c(seq(as.Date("21-06-1993", "%d-%m-%Y", tz = 'UTC'), - as.Date("21-09-1993","%d-%m-%Y", tz = 'UTC'), "day"), - seq(as.Date("21-06-1994", "%d-%m-%Y", tz = 'UTC'), - as.Date("21-09-1994","%d-%m-%Y", tz = 'UTC'), "day"), - seq(as.Date("21-06-1995", "%d-%m-%Y", tz = 'UTC'), - as.Date("21-09-1995","%d-%m-%Y", tz = 'UTC'), "day")) + as.Date("21-09-1993","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("21-06-1994", "%d-%m-%Y", tz = 'UTC'), + as.Date("21-09-1994","%d-%m-%Y", tz = 'UTC'), "day"), + seq(as.Date("21-06-1995", "%d-%m-%Y", tz = 'UTC'), + as.Date("21-09-1995","%d-%m-%Y", tz = 'UTC'), "day")) dim(output) <- c(time = 93, file_date = 3) - expect_equal(SelectPeriodOnDates(dates, list(21,6),list(21,9), time_dim = 'time'), output) + expect_equal( + SelectPeriodOnDates(dates, list(21,6),list(21,9), time_dim = 'time'), + output + ) dates <- s2dv::Reorder(dates, c('file_date', 'time')) output <- s2dv::Reorder(output, c('file_date', 'time')) - expect_equal(SelectPeriodOnDates(dates, list(21,6),list(21,9), time_dim = 'time'), output) + expect_equal( + SelectPeriodOnDates(dates, list(21,6),list(21,9), time_dim = 'time'), + output + ) + # test different common dimensions + + exp <- array(1:61, dim = c(ftime = 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) + res <- SelectPeriodOnData(data = exp, dates = Dates, + start = list(21, 4), end = list(21, 6)) + expect_equal( + dim(res), + c(ftime = 52) + ) + }) -test_that("Decadal", { +############################################## +test_that("3. Decadal", { # -------- 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)) # No dims -> test .position output <- c( seq(as.Date("2000-02-01", "%Y-%m-%d"), as.Date("2000-02-10", "%Y-%m-%d"), 'day'), @@ -43,17 +77,18 @@ test_that("Decadal", { dim(output) <- c(ftime = 60) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), - output) + output + ) data <- array(1:(length(dates)*3), c(memb = 1, ftime = 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(ftime = 60, memb = 1, lon = 3))) + c(memb = 1, ftime = 60, lon = 3)) + ) output2 <- c( seq(as.Date("2000-02-01", "%Y-%m-%d"), as.Date("2000-04-10", "%Y-%m-%d"), 'day'), @@ -65,23 +100,27 @@ test_that("Decadal", { dim(output2) <- c(ftime = 416) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), - output2) + output2 + ) expect_equal( SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4)), 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(ftime = 416, memb = 1, lon = 3))) + c(memb = 1, ftime = 416, lon = 3)) + ) # 1 dim -> test Apply dim(dates) <- c(ftime = length(dates)) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 2)), - output) # no need to check on Data, repited + output + ) # no need to check on Data, repited expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), - output2) # no need to check on Data, repited + output2 + ) # no need to check on Data, repited # decadal: 5 sdates several consequtive years dates <- rep(seq(as.Date("01-01-2000", "%d-%m-%Y", tz = 'UTC'), @@ -96,49 +135,54 @@ test_that("Decadal", { data <- array(1:(length(dates)*3), c(memb = 1, sdate = 5, ftime = 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], + 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)) + 1:10 * 5 + 5631, 1:10 * 5 + 7456, 1:10 * 5 + 9286) + ) output4 <- rep(output2, 5) dim(output4) <- c(ftime = 416, sdate = 5) expect_equal( SelectPeriodOnDates(dates, start = list(1, 2), end = list(10, 4)), - output4) + output4 + ) expect_equal( #To be extended for all ftime dimensions: - SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4))[1,1,,1], - 156:160) + SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 4))[1, ,1,1], + 156:160 + ) # Multiple dims: sdate, fyear, ftime - library(CSTools) - dates <- SplitDim(dates, indices = dates[,1], - split_dim = 'ftime', freq = 'year') + dates <- CSTools::SplitDim(dates, indices = dates[,1], + split_dim = 'ftime', freq = 'year') dates <- as.POSIXct(dates * 24 * 3600, origin = '1970-01-01', tz = 'UTC') - output5 <- SplitDim(output3, indices = output3[,1], split_dim = 'ftime' , freq = 'year') + output5 <- CSTools::SplitDim(output3, indices = output3[,1], split_dim = 'ftime' , 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) + output5 + ) data <- array(1:(366*6*5*3), c(memb = 1, sdate = 5, year = 6, ftime = 366, lon = 3)) expect_equal( SelectPeriodOnData(data, dates, start = list(1, 2), end = list(10, 2)), - InsertDim(Reorder(data[,,,32:41,], c('ftime', 'sdate', 'year', 'lon')), - len = 1, pos = 2, name = 'memb')) - output6 <- SplitDim(output4, indices = output4[,1], split_dim = 'ftime' , freq = 'year') + InsertDim(Reorder(data[, , , 32:41, ], c('sdate', 'year', 'ftime', 'lon')), + len = 1, pos = 1, name = 'memb') + ) + output6 <- CSTools::SplitDim(output4, indices = output4[,1], split_dim = 'ftime' , 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)), - output6) - #expect_equal( # to be fixed: + output6 + ) + # 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')), # len = 1, pos = 2, name = 'memb')) }) - -test_that("Seasonal", { +############################################## +test_that("4. Seasonal", { # 1 start month, select the required 'ftime' 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'), @@ -148,7 +192,7 @@ test_that("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) 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"), @@ -157,23 +201,26 @@ test_that("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 = (30 - 20 + 31 + 21) * 4) + dim(output) <- c(ftime = 62, sdate = 4) expect_equal( - SelectPeriodOnDates(dates, start = list(21, 4), end = list(21, 6)), - output) + SelectPeriodOnDates(dates, start = list(21, 4), end = list(21, 6)), + output + ) - # following the above case, and select the data + # 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) expect_equal( - SelectPeriodOnData(data, dates, start = list(21, 4), end = list(21, 6))[,1,1,1], - data[1,1,21:82,1]) + SelectPeriodOnData(data, dates, start = list(21, 4), end = list(21, 6))[1,1, ,1], + data[1,1,21:82,1] + ) -# when selecting the days across two years + # 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) output1 <- c(seq(as.Date("01-01-2000", format = "%d-%m-%Y"), as.Date("31-01-2000", format = "%d-%m-%Y"), by = 'day'), @@ -188,15 +235,18 @@ test_that("Seasonal", { dim(output1) <- c(ftime = 31 * 8) expect_equal( - SelectPeriodOnDates(dates, start = list(1, 12), end = list(31, 1)), - output1) - # following the above case, and select the data + SelectPeriodOnDates(dates, start = list(1, 12), end = list(31, 1)), + output1 + ) + + # following the above case, and select the data data1 <- array(1:(length(dates) * 2), c(memb = 1, ftime = 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(ftime = 31 * 8, memb = 1, lon = 2))) + 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)) + ) }) diff --git a/tests/testthat/test-Threshold.R b/tests/testthat/test-Threshold.R index 44f12914d3beee5647760f4af6af16d39c68453a..24ca6010fd895b35b824f5c83fba030280b3d45f 100644 --- a/tests/testthat/test-Threshold.R +++ b/tests/testthat/test-Threshold.R @@ -1,51 +1,84 @@ -context("Generic tests") +context("CSIndicators::Threshold tests") + test_that("Sanity checks", { - #source("csindicators/R/Threshold.R") - expect_error(Threshold(NULL), - "Parameter 'data' cannot be NULL.") - expect_error(Threshold('x'), - "Parameter 'data' must be numeric.") + expect_error( + Threshold(NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + Threshold('x'), + "Parameter 'data' must be numeric." + ) data <- 1:20 - expect_error(Threshold(data, NULL), - "Parameter 'threshold' cannot be NULL.") - expect_error(Threshold(data, 'x'), - "Parameter 'threshold' must be numeric.") + expect_error( + Threshold(data, NULL), + "Parameter 'threshold' cannot be NULL." + ) + expect_error( + Threshold(data, 'x'), + "Parameter 'threshold' must be numeric." + ) threshold <- 0.9 - expect_equal(Threshold(data, threshold), 18.1) + expect_equal( + Threshold(data, threshold), + 18.1 + ) dim(data) <- c(2, 10) - expect_error(Threshold(data, threshold), - "Parameter 'data' must have named dimensions.") + expect_error( + Threshold(data, threshold), + "Parameter 'data' must have named dimensions." + ) names(dim(data)) <- c('lat', 'sdate') - expect_error(Threshold(data, threshold), - "Could not find dimension 'member' in 1th object provided in 'data'.") - expect_equal(Threshold(data, threshold, memb_dim = NULL), - array(c(17.2, 18.2), c(lat = 2))) + expect_error( + Threshold(data, threshold), + "Could not find dimension 'member' in 1th object provided in 'data'." + ) + expect_equal( + Threshold(data, threshold, memb_dim = NULL), + array(c(17.2, 18.2), c(lat = 2)) + ) threshold <- c(0.1, 0.2) - expect_equal(Threshold(data, threshold, memb_dim = NULL), - array(c(2.8, 4.6, 3.8, 5.6), c(probs = 2, lat = 2))) + expect_equal( + 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)) - 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)), - c(probs = 2, x = 2)) + 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)), + c(probs = 2, x = 2) + ) # threshold with dimensions ? dim(threshold) <- c(member = 2, ftime = 1) - expect_equal(dim(Threshold(data, threshold, sdate_dim = 'ftime', memb_dim = NULL)), - c(probs = 2, x = 2)) - expect_equal(dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), - c(probs = 2)) + expect_equal( + dim(Threshold(data, threshold, sdate_dim = 'ftime', memb_dim = NULL)), + c(probs = 2, x = 2) + ) + expect_equal( + dim(Threshold(data, threshold, memb_dim = 'x', sdate_dim = 'ftime')), + c(probs = 2) + ) }) test_that("Seasonal forecasts", { - - exp <- CSTools::lonlat_data$exp$data + exp <- CSTools::lonlat_temp$exp$data thresholdP <- Threshold(exp, threshold = 0.9) - expect_equal(dim(exp)[4:6], dim(thresholdP)[2:4]) - expect_equal(round(thresholdP[1, , 2, 2]), c(283, 281, 280)) + expect_equal( + dim(exp)[4:6], + dim(thresholdP)[2:4] + ) + expect_equal( + round(thresholdP[1, , 2, 2]), + c(283, 281, 280) + ) exp1 <- exp[1, 1, 1, , , ] # no member - library(s2dv) # 1 member and 1 sdate - exp1 <- InsertDim(InsertDim(exp1, 1, 1, name = 'sdate'), 1, 1, name = 'member') + exp1 <- s2dv::InsertDim(InsertDim(exp1, 1, 1, name = 'sdate'), 1, 1, name = 'member') # 1 member and 1 sdate exp1_thresholdP <- Threshold(exp1, threshold = 0.9) - expect_equal(round(exp1_thresholdP[, 2, 2]), c(281, 279, 276)) - + expect_equal( + round(exp1_thresholdP[, 2, 2]), + c(281, 279, 276) + ) }) diff --git a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R index e09fb155ce5e0312f0d64a460331b71822e42ba0..d2155298df51c082450d75c7d449293020ff3c07 100644 --- a/tests/testthat/test-TotalSpellTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalSpellTimeExceedingThreshold.R @@ -1,55 +1,265 @@ -context("Generic tests") -test_that("Sanity checks", { - #source("csindicators/R/TotalSpellTimeExceedingThreshold.R") - expect_error(TotalSpellTimeExceedingThreshold(NULL), - "Parameter 'data' cannot be NULL.") - expect_error(TotalSpellTimeExceedingThreshold('x'), - "Parameter 'data' must be numeric.") - data <- 1:20 - expect_error(TotalSpellTimeExceedingThreshold(data, NULL), - "Parameter 'threshold' cannot be NULL.") - expect_error(TotalSpellTimeExceedingThreshold(data, 'x'), - "Parameter 'threshold' must be numeric.") - threshold <- 10 - expect_error(TotalSpellTimeExceedingThreshold(data, threshold), - paste("argument", '"spell"', "is missing, with no default")) - dim(data) <- c(2, 10) - expect_error(TotalSpellTimeExceedingThreshold(data, threshold, spell = 2), - "Parameter 'data' must have named dimensions.") - names(dim(data)) <- c('time', 'lat') - threshold <- array(1:2, 2) - dim(threshold) <- c(time = 2) - expect_equal(TotalSpellTimeExceedingThreshold(data, threshold, spell = 2), - array(c(0,rep(2,9)), c(lat = 10))) - data <- array(1:40, c(x = 2, ftime = 20)) - expect_error(TotalSpellTimeExceedingThreshold(data, threshold, spell = 2), - "Could not find dimension 'time' in 1th object provided in 'data'.") - threshold <- 10 - expect_equal(TotalSpellTimeExceedingThreshold(data, threshold, spell = 2, time_dim = 'ftime'), - array(c(15, 15), c(x = 2))) - threshold <- rep(10, 20) - dim(threshold) <- c(member = 1, ftime = 20) - expect_equal(TotalSpellTimeExceedingThreshold(data, threshold, spell = 2, time_dim = 'ftime'), - array(c(15, 15), c(x = 2, member = 1))) - expect_error(TotalSpellTimeExceedingThreshold(data, threshold, spell = 2, time_dim = 'y'), - paste("Could not find dimension 'y' in 1th object provided in 'data'")) +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)) + +# 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)) +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)) + +# dat4 +set.seed(1) +dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +set.seed(1) +thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +set.seed(2) +thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +set.seed(1) +thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +set.seed(2) +thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +set.seed(1) +thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +set.seed(2) +thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +set.seed(1) +thres4_7 <- rnorm(5, 20) +set.seed(2) +thres4_8 <- rnorm(5, 25) + +########################################################################### +test_that("1. Sanity checks", { + # data + expect_error( + TotalSpellTimeExceedingThreshold(NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + TotalSpellTimeExceedingThreshold('x'), + "Parameter 'data' must be numeric." + ) + expect_error( + TotalSpellTimeExceedingThreshold(array(dat1, dim = c(2, 10)), 10), + "Parameter 'data' must have named dimensions." + ) + # time_dim + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + TotalSpellTimeExceedingThreshold(array(dat1, dim = c('sdate' = 20)), 10), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # op + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, op = 1, time_dim = 'time'), + "Parameter 'op' must be a character." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, op = 'a', time_dim = 'time'), + "Parameter 'op' must be a logical operator." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, op = c('=','='), time_dim = 'time'), + "Parameter 'op' is not an accepted pair of logical operators." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, op = c('=','<','>'), time_dim = 'time'), + "Parameter 'op' must be a logical operator with length 1 or 2." + ) + # threshold + expect_error( + TotalSpellTimeExceedingThreshold(1:20, NULL), + "Parameter 'threshold' cannot be NULL." + ) + expect_error( + TotalSpellTimeExceedingThreshold(1:20, 'x'), + "Parameter 'threshold' must be numeric." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, op = c("<",">"), spell = 6,time_dim = 'time'), + "If 'op' is a pair of logical operators parameter 'threshold' also has to be a pair of values." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, list(1:10,1:20), op = c("<",">"), spell = 6, time_dim = 'time'), + "The pair of thresholds must have the same length." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, list(array(1:10, c(lat = 2, lon = 5)),array(1:10, c(time = 5, lon = 2))), op = c("<",">"), spell = 6, time_dim = 'time'), + "The pair of thresholds must have the same dimension names." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, list(array(1:10, c(lat = 2, lon = 5)),array(1:10, c(time = 2, lon = 5))), op = c("<",">"), spell = 6, time_dim = 'time'), + "The pair of thresholds must have the same dimension names." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, list(array(1:3, c(time = 3)),array(1:3, c(time = 3))), op = c("<",">"), spell = 6, time_dim = 'time'), + "Parameter 'data' and 'threshold' must have same length of all common dimensions." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 1:10, spell = 6, op = "<", time_dim = 'time'), + "If parameter 'threshold' is a vector it must have the same length as data time dimension." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, array(rnorm(10)), spell = 6, op = "<", time_dim = 'time'), + "If parameter 'threshold' is an array it must have named dimensions." + ) + expect_error( + TotalSpellTimeExceedingThreshold(dat1, array(3, dim = c(time = 3)), op = "<", spell = 6, time_dim = 'time'), + "Parameter 'data' and 'threshold' must have same length of all common dimensions." + ) + # spell + expect_error( + TotalSpellTimeExceedingThreshold(1:20, thres), + paste("argument", '"spell"', "is missing, with no default") + ) + expect_error( + TotalSpellTimeExceedingThreshold(1:20, thres, spell = 1:2), + "Parameter 'spell' must be a scalar." + ) + # ncores + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, time_dim = 'time', spell = 6, ncores = 1.5), + "Parameter 'ncores' must be a positive integer." + ) + # dates + expect_error( + TotalSpellTimeExceedingThreshold(dat1, 10, op = "<", dates = 2, spell = 6, start = 'a', end = 'b', time_dim = 'time'), + paste0("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + ) +}) + +########################################################################### + +test_that("2. Output checks", { + expect_equal( + TotalSpellTimeExceedingThreshold(dat1, thres1, spell = 2, time_dim = 'time'), + array(c(0,rep(2,9)), c(lat = 10)) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat1_2, 10, spell = 2), + array(c(15, 15), c(x = 2)) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat1_2,threshold1_2, spell = 2), + array(c(15, 15), c(x = 2, member = 1)) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat2_1, thres2_1, spell = 10), + array(c(15, 15), c(x = 2)) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat2_1, thres2_1, spell = 2, time_dim = 'x'), + array(c(rep(0,5), rep(2,15)), c(ftime = 20)) + ) + # dimensions + expect_equal( + dim(TotalSpellTimeExceedingThreshold(dat2_3, thres2_3, spell = 3)), + c(sdate = 2, lat = 2) + ) + expect_equal( + dim(TotalSpellTimeExceedingThreshold(dat2_3, thres2_4, spell = 3)), + c(sdate = 2, lat = 2) + ) + expect_equal( + dim(TotalSpellTimeExceedingThreshold(dat2_4, thres2_4, spell = 3, time_dim = 'ftime')), + c(fyear = 3, sdate = 2, lat = 2) + ) +}) + +############################################## + +test_that("3. Output checks", { + + expect_equal( + dim(TotalSpellTimeExceedingThreshold(dat3_1, c(55,58), spell = 3, c('<', '>'))), + c(fyear = 3, sdate = 2, lat = 2) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat3_1, c(30,60), spell = 3, c(">", "<")), + array(c(rep(0,6),rep(5, 5), 4), dim = c(fyear = 3, sdate = 2, lat = 2)) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat3_1, c(55,58), spell = 3, c(">=", "<=")), + 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'), + array(c(0, 3), c(x = 2)) + ) + expect_equal( + TotalSpellTimeExceedingThreshold(dat3_2, c(7,11), spell = 3, op = c('>=', '<='), time_dim = 'ftime'), + array(c(3, 0), c(x = 2)) + ) + expect_equal( + dim(TotalSpellTimeExceedingThreshold(dat2_3, list(thres2_4, thres2_4+1), spell = 3, op = c('>=', '<'))), + c(sdate = 2, lat = 2) + ) + +}) + +############################################## + +test_that("4. Output checks", { + + expect_equal( + dim(TotalSpellTimeExceedingThreshold(dat4, list(thres4_2, thres4_1), spell = 3, c('<=', '>'))), + c(fyear = 3, sdate = 2, lat = 2) + ) + expect_equal( + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_1, thres4_2), spell = 3, c(">", "<="))[1:3]), + c(3, 5, 0) + ) + expect_equal( + as.vector(TotalSpellTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), spell = 4, c(">", "<="), time_dim = 'ftime'))[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], + 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], + c(5, 3, 5, 4, 3, 5, 5) + ) }) -test_that("Seasonal Forecasts", { +########################################################################### - exp <- CSTools::lonlat_data$exp +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) - expect_equal(res$data[,,1,1], - array(c(3,3,3,3,3,3,3,3,3), c(member = 3, sdate = 3))) + 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) - 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))) + 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) - expect_equal(WSDI1$data[3,3,3,], - c(rep(0, 53))) + expect_equal( + WSDI1$data[3,3,3,], + c(rep(0, 53))) }) diff --git a/tests/testthat/test-TotalTimeExceedingThreshold.R b/tests/testthat/test-TotalTimeExceedingThreshold.R index 408764b734b2621ebbce9edcfcf84666214fdb04..68c6d777f2dddb896380cb902488451680862cba 100644 --- a/tests/testthat/test-TotalTimeExceedingThreshold.R +++ b/tests/testthat/test-TotalTimeExceedingThreshold.R @@ -1,74 +1,254 @@ -context("Generic tests") -test_that("Sanity checks", { - #source("csindicators/R/TotalTimeExceedingThreshold.R") - expect_error(TotalTimeExceedingThreshold(NULL), - "Parameter 'data' cannot be NULL.") - expect_error(TotalTimeExceedingThreshold('x'), - "Parameter 'data' must be numeric.") - data <- 1:20 - expect_error(TotalTimeExceedingThreshold(data, NULL), - "Parameter 'threshold' cannot be NULL.") - expect_error(TotalTimeExceedingThreshold(data, 'x'), - "Parameter 'threshold' must be numeric.") - threshold <- 10 - expect_equal(TotalTimeExceedingThreshold(data, threshold), 10) - dim(data) <- c(2, 10) - expect_error(TotalTimeExceedingThreshold(data, threshold), - "Parameter 'data' must have named dimensions.") - names(dim(data)) <- c('lat', 'time') - threshold <- array(1:2, 2) - expect_error(TotalTimeExceedingThreshold(data, threshold), - "Parameter 'threshold' must have named dimensions.") - dim(threshold) <- c(time = 2) - expect_error(TotalTimeExceedingThreshold(data, threshold), - "Parameter 'data' and 'threshold' must have the same length on common dimensions.") - data <- array(1:40, c(x = 2, ftime = 20)) - expect_error(TotalTimeExceedingThreshold(data, threshold), - "Could not find dimension 'time' in 1th object provided in 'data'.") - threshold <- 10 - expect_equal(TotalTimeExceedingThreshold(data, threshold, time_dim = 'ftime'), - array(c(15, 15), c(x = 2))) - dim(threshold) <- c(member = 1, ftime = 1) - expect_equal(TotalTimeExceedingThreshold(data, threshold, time_dim = 'ftime'), - array(c(15, 15), c(x = 2))) - expect_equal(TotalTimeExceedingThreshold(data, threshold, time_dim = 'x'), - array(c(rep(0,5), rep(2,15)), c(ftime = 20))) - expect_error(TotalTimeExceedingThreshold(data, threshold, - time_dim = 'x', ncores = 'Z'), - "Parameter 'ncores' must be numeric") +context("CSIndicators::TotalTimeExceedingThreshold tests") - expect_equal(TotalTimeExceedingThreshold(data, threshold, time_dim = 2), - array(c(15,15), c(x = 2))) - # dimensions: - data <- array(1:20, c(time = 5, sdate = 2, lat = 2)) - # does this case made sense? - threshold <- array(1:5, c(time = 5)) - expect_equal(dim(TotalTimeExceedingThreshold(data, threshold)), - c(sdate = 2, lat = 2)) - threshold <- array(1:2, c(lat = 2)) - expect_equal(dim(TotalTimeExceedingThreshold(data, threshold)), - c(sdate = 2, lat = 2)) - data <- array(1:60, c(time = 5, fyear = 3, sdate = 2, lat = 2)) - expect_equal(dim(TotalTimeExceedingThreshold(data, threshold, - time_dim = c('time', 'fyear'))), - c(sdate = 2, lat = 2)) +# 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)) +# 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)) +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)) + +# dat4 +set.seed(1) +dat4 <- array(rnorm(60, 23), c(ftime = 5, fyear = 3, sdate = 2, lat = 2)) +set.seed(1) +thres4_1 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2, lat = 2)) +set.seed(2) +thres4_2 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2, lat = 2)) +set.seed(1) +thres4_3 <- array(rnorm(20, 20), c(ftime = 5, sdate = 2)) +set.seed(2) +thres4_4 <- array(rnorm(20, 25), c(ftime = 5, sdate = 2)) +set.seed(1) +thres4_5 <- array(rnorm(5, 20), c(ftime = 5)) +set.seed(2) +thres4_6 <- array(rnorm(5, 25), c(ftime = 5)) +set.seed(1) +thres4_7 <- rnorm(5, 20) +set.seed(2) +thres4_8 <- rnorm(5, 25) + +########################################################################### + +test_that("1. Sanity checks", { + # data + expect_error( + TotalTimeExceedingThreshold(NULL), + "Parameter 'data' cannot be NULL." + ) + expect_error( + TotalTimeExceedingThreshold('x'), + "Parameter 'data' must be numeric." + ) + expect_error( + TotalTimeExceedingThreshold(array(dat1, dim = c(2, 10)), 10), + "Parameter 'data' must have named dimensions." + ) + # time_dim + expect_error( + TotalTimeExceedingThreshold(dat1, 10, time_dim = 1), + "Parameter 'time_dim' must be a character string." + ) + expect_error( + TotalTimeExceedingThreshold(array(dat1, dim = c('sdate' = 20)), 10), + "Parameter 'time_dim' is not found in 'data' dimension." + ) + # op + expect_error( + TotalTimeExceedingThreshold(dat1, 10, op = 1, time_dim = 'time'), + "Parameter 'op' must be a character." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, 10, op = 'a', time_dim = 'time'), + "Parameter 'op' must be a logical operator." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, 10, op = c('=','='), time_dim = 'time'), + "Parameter 'op' is not an accepted pair of logical operators." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, 10, op = c('=','<','>'), time_dim = 'time'), + "Parameter 'op' must be a logical operator with length 1 or 2." + ) + # threshold + expect_error( + TotalTimeExceedingThreshold(1:20, NULL), + "Parameter 'threshold' cannot be NULL." + ) + expect_error( + TotalTimeExceedingThreshold(1:20, 'x'), + "Parameter 'threshold' must be numeric." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, 10, op = c("<",">"), time_dim = 'time'), + "If 'op' is a pair of logical operators parameter 'threshold' also has to be a pair of values." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, list(1:10,1:20), op = c("<",">"), time_dim = 'time'), + "The pair of thresholds must have the same length." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, list(array(1:10, c(lat = 2, lon = 5)),array(1:10, c(time = 5, lon = 2))), op = c("<",">"), time_dim = 'time'), + "The pair of thresholds must have the same dimension names." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, list(array(1:10, c(lat = 2, lon = 5)),array(1:10, c(time = 2, lon = 5))), op = c("<",">"), time_dim = 'time'), + "The pair of thresholds must have the same dimension names." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, list(array(1:3, c(time = 3)),array(1:3, c(time = 3))), op = c("<",">"), time_dim = 'time'), + "Parameter 'data' and 'threshold' must have same length of all common dimensions." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, 1:10, op = "<", time_dim = 'time'), + "If parameter 'threshold' is a vector it must have the same length as data time dimension." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, array(rnorm(10)), op = "<", time_dim = 'time'), + "If parameter 'threshold' is an array it must have named dimensions." + ) + expect_error( + TotalTimeExceedingThreshold(dat1, array(3, dim = c(time = 3)), op = "<", time_dim = 'time'), + "Parameter 'data' and 'threshold' must have same length of all common dimensions." + ) + # ncores + expect_error( + TotalTimeExceedingThreshold(dat1, 10, time_dim = 'time', ncores = 1.5), + "Parameter 'ncores' must be a positive integer." + ) + # dates + expect_error( + TotalTimeExceedingThreshold(dat1, 10, op = "<", dates = 2, start = 'a', end = 'b', time_dim = 'time'), + paste0("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + ) }) + +########################################################################### + +test_that("2. Output checks", { + expect_equal( + TotalTimeExceedingThreshold(dat1, thres1, time_dim = 'time'), + array(c(0,rep(2,9)), c(lat = 10)) + ) + expect_equal( + TotalTimeExceedingThreshold(dat1_2, 10), + array(c(15, 15), c(x = 2)) + ) + expect_equal( + TotalTimeExceedingThreshold(dat1_2,threshold1_2), + array(c(15, 15), c(x = 2, member = 1)) + ) + expect_equal( + TotalTimeExceedingThreshold(dat2_1, thres2_1), + array(c(15, 15), c(x = 2)) + ) + expect_equal( + TotalTimeExceedingThreshold(dat2_1, thres2_1, time_dim = 'x'), + array(c(rep(0,5), rep(2,15)), c(ftime = 20)) + ) + # dimensions + expect_equal( + dim(TotalTimeExceedingThreshold(dat2_3, thres2_3)), + c(sdate = 2, lat = 2) + ) + expect_equal( + dim(TotalTimeExceedingThreshold(dat2_3, thres2_4)), + c(sdate = 2, lat = 2) + ) + expect_equal( + dim(TotalTimeExceedingThreshold(dat2_4, thres2_4, time_dim = 'ftime')), + c(fyear = 3, sdate = 2, lat = 2) + ) +}) + +############################################## + +test_that("3. Output checks", { + expect_equal( + dim(TotalTimeExceedingThreshold(dat3_1, c(55,58), c('<', '>'))), + c(fyear = 3, sdate = 2, lat = 2) + ) + expect_equal( + TotalTimeExceedingThreshold(dat3_1, c(30,60), c(">", "<")), + array(c(rep(0, 6), rep(5, 5), 4), dim = c(fyear = 3, sdate = 2, lat = 2)) + ) + expect_equal( + TotalTimeExceedingThreshold(dat3_1, c(55, 58), c(">=", "<=")), + 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'), + array(c(2, 3), c(x = 2)) + ) + expect_equal( + TotalTimeExceedingThreshold(dat3_2, c(7, 11), op = c('>=', '<='), time_dim = 'ftime'), + array(c(3, 2), c(x = 2)) + ) + expect_equal( + dim(TotalTimeExceedingThreshold(dat2_3, list(thres2_4, thres2_4+1), op = c('>=', '<'))), + c(sdate = 2, lat = 2) + ) +}) + +############################################## + +test_that("4. Output checks", { + expect_equal( + dim(TotalTimeExceedingThreshold(dat4, list(thres4_2, thres4_1), c('<=', '>'))), + c(fyear = 3, sdate = 2, lat = 2) + ) + expect_equal( + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_1, thres4_2), c(">", "<="))[1:3]), + c(4, 5, 3) + ) + expect_equal( + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_3, thres4_4), c(">", "<="), time_dim = 'ftime'))[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], + c(4, 5, 3, 5, 4) + ) + expect_equal( + as.vector(TotalTimeExceedingThreshold(dat4, list(thres4_7, thres4_8), op = c('>=', '<='), time_dim = 'ftime'))[4:10], + c(5, 4, 5, 4, 4, 5, 5) + ) +}) + +########################################################################### + test_that("Seasonal forecasts", { # compare with scalar fixed threshold - exp <- CSTools::lonlat_data$exp - exp$data <- exp$data[1,1:3,,,,] - 247 + 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 - expect_equal(SU35_NoP[1,,15,3], c(0,1,1,1,0,0)) + expect_equal( + SU35_NoP[1, , 15, 3], + c(0, 1, 1, 1, 0, 0) + ) # convert to percentile - obs <- CSTools::lonlat_data$obs exp_percentile <- AbsToProbs(exp$data) obs_percentile <- drop(QThreshold(obs$data, threshold = 35)) data <- exp data$data <- exp_percentile SU35_P <- CST_TotalTimeExceedingThreshold(data, threshold = obs_percentile)$data - expect_equal(SU35_P[,2,5,5], c(3,3,3,3,3,3)) + expect_equal( + SU35_P[2, , 5, 5], + c(3, 3, 3, 3, 3, 3) + ) }) - - diff --git a/tests/testthat/test-WindCapacityFactor.R b/tests/testthat/test-WindCapacityFactor.R new file mode 100644 index 0000000000000000000000000000000000000000..1bf9089e2fd3eef4ee9903f4c136f5fdf22c5906 --- /dev/null +++ b/tests/testthat/test-WindCapacityFactor.R @@ -0,0 +1,49 @@ +context("CSIndicators::WindCapacityFactor tests") + +# dat1 +wind <- NULL +wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), + c(member = 10, lat = 2, lon = 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') +class(wind) <- 's2dv_cube' +WCF <- CST_WindCapacityFactor(wind, IEC_class = "III") + +########################################################################### +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_WindCapacityFactor(wind = 1), + "Parameter 'wind' must be of the class 's2dv_cube'." + ) + # Dates subset + expect_warning( + CST_WindCapacityFactor(wind = wind, start = list(1,3), end = list(1,7)), + paste0("Dimensions in 'wind' element 'attrs$Dates' are missed and ", + "all data would be used."), + fixed = TRUE + ) + # start and end + expect_error( + WindCapacityFactor(wind = wind$data, dates = wind$attrs$Dates, + start = c(1,2), end = c(2,3)), + paste0("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + ) +}) + +########################################################################### +test_that("2. Output checks", { + expect_equal( + CST_WindCapacityFactor(wind = wind)$attrs$Variable$varName, + 'WindCapacityFactor' + ) + expect_equal( + dim(CST_WindCapacityFactor(wind = wind)$data), + c(member = 10, lat = 2, lon = 5) + ) +}) + diff --git a/tests/testthat/test-WindPowerDensity.R b/tests/testthat/test-WindPowerDensity.R new file mode 100644 index 0000000000000000000000000000000000000000..249c5290cfb43ddf49ba7bacef4747875763de32 --- /dev/null +++ b/tests/testthat/test-WindPowerDensity.R @@ -0,0 +1,48 @@ +context("CSIndicators::WindPowerDensity tests") + +# dat1 +wind <- NULL +wind$data <- array(rweibull(n = 100, shape = 2, scale = 6), + c(member = 10, lat = 2, lon = 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') +class(wind) <- 's2dv_cube' + +########################################################################### +test_that("1. Input checks", { + # Check 's2dv_cube' + expect_error( + CST_WindPowerDensity(wind = 1), + "Parameter 'wind' must be of the class 's2dv_cube'." + ) + # Dates subset + expect_warning( + CST_WindPowerDensity(wind = wind, start = list(1,3), end = list(1,7)), + paste0("Dimensions in 'wind' element 'attrs$Dates' are missed and ", + "all data would be used."), + fixed = TRUE + ) + # start and end + expect_error( + WindPowerDensity(wind = wind$data, dates = wind$attrs$Dates, + start = c(1,2), end = c(2,3)), + paste0("Parameter 'start' and 'end' must be lists indicating the ", + "day and the month of the period start and end.") + ) +}) + +########################################################################### +test_that("2. Output checks", { + expect_equal( + CST_WindPowerDensity(wind = wind)$attrs$Variable$varName, + 'WindPowerDensity' + ) + expect_equal( + dim(CST_WindPowerDensity(wind = wind)$data), + c(member = 10, lat = 2, lon = 5) + ) +}) + diff --git a/vignettes/AgriculturalIndicators.Rmd b/vignettes/AgriculturalIndicators.Rmd index 50df881aefb029551ee3fdb74600c9beb4b426a6..3c9cf7d23a9b4fd68b8f819638c85f328bd7c761 100644 --- a/vignettes/AgriculturalIndicators.Rmd +++ b/vignettes/AgriculturalIndicators.Rmd @@ -84,7 +84,6 @@ c(prlr_exp, prlr_obs) %<-% CST_Load(var = 'prlr', grid = "r1440x721", method = 'bicubic') ``` - The output contains data and metadata for the experiment and the observations. The elements `prlr_exp$data` and `prlr_obs$data` have dimensions: @@ -97,10 +96,8 @@ dim(prlr_obs$data) # 1 1 4 214 4 4 ``` - To compute **SprR** of forecast and observation, we can run: - ``` 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)) @@ -124,7 +121,7 @@ dim(SprR_obs$data) 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 +SprR_exp$data[1, 1, , 1, 1] * 86400 * 1000 #[1] 93.23205 230.41904 194.01412 226.52614 ``` @@ -140,7 +137,7 @@ HarvestR_obs <- CST_PeriodAccumulation(prlr_obs, start = list(21, 8), end = list 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 +HarvestR_exp$data[1, 1, , 1, 1] * 86400 * 1000 #[1] 52.30026 42.88068 156.87961 32.18579 ``` @@ -159,7 +156,7 @@ To plot the map of ensemble-mean bias of HarvestR forecast, run cols <- c('#b2182b', '#d6604d', '#f4a582', '#fddbc7', '#d1e5f0', '#92c5de', '#4393c3', '#2166ac') -PlotEquiMap(Bias[1,,], lon = prlr_obs$lon, lat = prlr_obs$lat, +PlotEquiMap(Bias[1, , ], lon = prlr_obs$coords$lon, lat = prlr_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'mm', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, col_inf = cols[1], @@ -170,7 +167,7 @@ PlotEquiMap(Bias[1,,], lon = prlr_obs$lon, lat = prlr_obs$lat, ``` You will see the following maps of HarvestR bias in 2013. - +![HarvestR_Bias_2013](./Figures/HarvestR_Bias_2013-1.png) In 2013, the ensemble-mean SEAS5 seasonal forecast of HarvestR is underestimated by up to 60 mm over Douro Valley region (the central four grid points). @@ -258,7 +255,7 @@ Here, we plot the 2013-2016 mean climatology of ERA5 GST by running GST_Clim <- MeanDims(drop(GST_obs$data), 'sdate') cols <- c('#ffffd4','#fee391','#fec44f','#fe9929','#ec7014','#cc4c02','#8c2d04') -PlotEquiMap(GST_Clim, lon = tas_obs$lon, lat = tas_obs$lat, +PlotEquiMap(GST_Clim, lon = tas_obs$coords$lon, lat = tas_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = '°C', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, col_inf = cols[1], @@ -270,7 +267,7 @@ PlotEquiMap(GST_Clim, lon = tas_obs$lon, lat = tas_obs$lat, The ERA5 GST climatology is shown as below. - +![ERA5 GST Climatology](./Figures/GST_ERA5_Climatology-1.png) ERA5 GST ranges from 17-18.5°C over the Douro Valley region for the period from 2013-2016 as shown in the figure. @@ -363,7 +360,8 @@ SU35_exp_BC_Y2016 <- MeanDims(SU35_exp_BC[, 4, , ], 'member') cols <- c("#fee5d9", "#fcae91", "#fb6a4a", "#de2d26","#a50f15") toptitle <- 'ERA5 SU35 forecast in 2016' -PlotEquiMap(SU35_obs_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, +PlotEquiMap(SU35_obs_Y2016, + lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'day', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, margin_scale = c(1, 1, 1, 1), @@ -373,7 +371,8 @@ PlotEquiMap(SU35_obs_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, bar_extra_margin = c(0, 0, 0, 0), units_scale = 2) toptitle <- 'SU35 forecast in 2016' -PlotEquiMap(SU35_exp_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, +PlotEquiMap(SU35_exp_Y2016, + lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'day', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, margin_scale = c(1, 1, 1, 1), @@ -383,7 +382,8 @@ PlotEquiMap(SU35_exp_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, bar_extra_margin = c(0, 0, 0, 0), units_scale = 2) toptitle <- 'Bias-adjusted SU35 forecast in 2016' -PlotEquiMap(SU35_exp_BC_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, +PlotEquiMap(SU35_exp_BC_Y2016, + lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'day', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, margin_scale = c(1, 1, 1, 1), @@ -395,9 +395,9 @@ PlotEquiMap(SU35_exp_BC_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, You can see the figure as below. - - - +![SU35_ERA5_Y2016](./Figures/SU35_ERA5_Y2016-1.png) +![SU35_SEAS5_Y2016](./Figures/SU35_SEAS5_Y2016-1.png) +![SU35_SEAS5_BC_Y2016](./Figures/SU35_SEAS5_BC_Y2016-1.png) As seen above, the bias-adjusted SU35 forecasts are much closer to the ERA5 results, although differences remain. @@ -429,20 +429,22 @@ obs_percentile <- drop(obs_percentile) After translating both forecasts and observations into probabilities, the comparison can then be done by running ``` -SU35_exp_Percentile <- TotalTimeExceedingThreshold(S5txP, threshold = obs_percentile, time_dim = 'ftime') +SU35_exp_Percentile <- TotalTimeExceedingThreshold(S5txP, threshold = obs_percentile, + time_dim = 'ftime') ``` Compute the same ensemble-mean SU35 **with percentile adjustment** in 2016 by running ``` -SU35_exp_per_Y2016 <- MeanDims(SU35_exp_Percentile[, 4, , ], 'member') +SU35_exp_per_Y2016 <- MeanDims(SU35_exp_Percentile[4, , , ], 'member') ``` Plot the same map for comparison ``` toptitle <- 'SU35 forecast with percentile adjustment in 2016' -PlotEquiMap(SU35_exp_per_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, +PlotEquiMap(SU35_exp_per_Y2016, + lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'day', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, margin_scale = c(1, 1, 1, 1), @@ -452,9 +454,7 @@ PlotEquiMap(SU35_exp_per_Y2016, lon = tasmax_obs$lon, lat = tasmax_obs$lat, bar_extra_margin = c(0, 0, 0, 0), units_scale = 2) ``` - - - +![SU35_Percentile_SEAS5_Y2016](./Figures/SU35_Percentile_SEAS5_Y2016-1.png) As seen in the figure above, applying the percentile adjustment seems to implicitly adjust certain extent of bias which was observed in the non-bias-adjusted SEAS5 forecast. @@ -501,7 +501,7 @@ To plot the map of correlation coefficient of GDD for the 2013-2016 period. ``` cols <- c("#f7fcf5", "#e5f5e0", "#c7e9c0", "#a1d99b", "#74c476") toptitle <- '2013-2016 correlation coefficient of GDD' -PlotEquiMap(GDD_Corr, lon = tas_obs$lon, lat = tas_obs$lat, +PlotEquiMap(GDD_Corr, lon = tas_obs$coords$lon, lat = tas_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'correlation', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, @@ -512,7 +512,7 @@ PlotEquiMap(GDD_Corr, lon = tas_obs$lon, lat = tas_obs$lat, The map of correlation coefficient for the 2013-2016 period is shown as below. - +![GDD_SEAS5_Corr_Y13-16](./Figures/GDD_SEAS5_Corr_Y13-16-1.png) The 2013-2016 correlation coefficients of the SEAS5 forecasts of GDD in reference with ERA5 reanalysis over Douro Valley range between 0.6 and 0.8. @@ -572,7 +572,7 @@ Plot the map of WSDI FRPSS for the period from 2013-2016 cols <- c("#edf8fb", "#ccece6", "#99d8c9", "#66c2a4") toptitle <- 'SEAS5 WSDI FRPSS (2013-2016)' -PlotEquiMap(WSDI_FRPSS, lon = tasmax_obs$lon, lat = tasmax_obs$lat, +PlotEquiMap(WSDI_FRPSS, lon = tasmax_obs$coords$lon, lat = tasmax_obs$coords$lat, intylat = 1, intxlon = 1, width = 6, height = 6, filled.continents = FALSE, units = 'FRPSS', title_scale = .8, axes_label_scale = 1, axes_tick_scale = 1, margin_scale = c(1, 1, 1, 1), @@ -583,7 +583,8 @@ PlotEquiMap(WSDI_FRPSS, lon = tasmax_obs$lon, lat = tasmax_obs$lat, The FRPSS map for 2013-2016 SEAS WSDI is shown as below. - +![WSDI_SEAS5_FRPSS_Y13-16](./Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png) + As seen in the map, the FRPSS in the eastern part of Douro Valley falls in 0.6-0.9, which are good enough to be useful when compared to observational climatology. diff --git a/vignettes/EnergyIndicators.Rmd b/vignettes/EnergyIndicators.Rmd index caf474e68d2ba86a04b41f87d9efa300d216cf6a..f4a1a04b722a6b250efadc015808dc5691811969 100644 --- a/vignettes/EnergyIndicators.Rmd +++ b/vignettes/EnergyIndicators.Rmd @@ -38,7 +38,7 @@ wind <- rweibull(n = 1000, shape = 2, scale = 6) WPD <- WindPowerDensity(wind) mean(WPD) sd(WPD) -par(mfrow=c(1, 2)) +par(mfrow = c(1, 2)) hist(wind, breaks = seq(0, 20)) hist(WPD, breaks = seq(0, 4000, 200)) ``` @@ -64,7 +64,7 @@ Following on the previous example, we will compute now the CF that would be obta ```{r, fig.width=7} WCFI <- WindCapacityFactor(wind, IEC_class = "I") WCFIII <- WindCapacityFactor(wind, IEC_class = "III") -par(mfrow=c(1, 3)) +par(mfrow = c(1, 3)) hist(wind, breaks = seq(0, 20)) hist(WCFI, breaks = seq(0, 1, 0.05), ylim = c(0, 500)) hist(WCFIII, breaks = seq(0, 1, 0.05), ylim = c(0, 500)) diff --git a/vignettes/figures/GDD_SEAS5_Corr_Y13-16-1.png b/vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png similarity index 100% rename from vignettes/figures/GDD_SEAS5_Corr_Y13-16-1.png rename to vignettes/Figures/GDD_SEAS5_Corr_Y13-16-1.png diff --git a/vignettes/figures/GST_ERA5_Climatology-1.png b/vignettes/Figures/GST_ERA5_Climatology-1.png similarity index 100% rename from vignettes/figures/GST_ERA5_Climatology-1.png rename to vignettes/Figures/GST_ERA5_Climatology-1.png diff --git a/vignettes/figures/HarvestR_Bias_2013-1.png b/vignettes/Figures/HarvestR_Bias_2013-1.png similarity index 100% rename from vignettes/figures/HarvestR_Bias_2013-1.png rename to vignettes/Figures/HarvestR_Bias_2013-1.png diff --git a/vignettes/figures/SU35_ERA5_Y2016-1.png b/vignettes/Figures/SU35_ERA5_Y2016-1.png similarity index 100% rename from vignettes/figures/SU35_ERA5_Y2016-1.png rename to vignettes/Figures/SU35_ERA5_Y2016-1.png diff --git a/vignettes/figures/SU35_Percentile_SEAS5_Y2016-1.png b/vignettes/Figures/SU35_Percentile_SEAS5_Y2016-1.png similarity index 100% rename from vignettes/figures/SU35_Percentile_SEAS5_Y2016-1.png rename to vignettes/Figures/SU35_Percentile_SEAS5_Y2016-1.png diff --git a/vignettes/figures/SU35_SEAS5_BC_Y2016-1.png b/vignettes/Figures/SU35_SEAS5_BC_Y2016-1.png similarity index 100% rename from vignettes/figures/SU35_SEAS5_BC_Y2016-1.png rename to vignettes/Figures/SU35_SEAS5_BC_Y2016-1.png diff --git a/vignettes/figures/SU35_SEAS5_Y2016-1.png b/vignettes/Figures/SU35_SEAS5_Y2016-1.png similarity index 100% rename from vignettes/figures/SU35_SEAS5_Y2016-1.png rename to vignettes/Figures/SU35_SEAS5_Y2016-1.png diff --git a/vignettes/figures/WCF_histogram.png b/vignettes/Figures/WCF_histogram.png similarity index 100% rename from vignettes/figures/WCF_histogram.png rename to vignettes/Figures/WCF_histogram.png diff --git a/vignettes/figures/WPD_histogram.png b/vignettes/Figures/WPD_histogram.png similarity index 100% rename from vignettes/figures/WPD_histogram.png rename to vignettes/Figures/WPD_histogram.png diff --git a/vignettes/figures/WSDI_SEAS5_FRPSS_Y13-16-1.png b/vignettes/Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png similarity index 100% rename from vignettes/figures/WSDI_SEAS5_FRPSS_Y13-16-1.png rename to vignettes/Figures/WSDI_SEAS5_FRPSS_Y13-16-1.png