From d505a8013bf26b7eecbcd7838addd6c72f63fff9 Mon Sep 17 00:00:00 2001
From: Dorchies David <david.dorchies@irstea.fr>
Date: Sat, 9 Jan 2021 22:58:46 +0100
Subject: [PATCH] feat(SeriesAggreg): Add internal quantile function
Fix #82
---
R/SeriesAggreg.data.frame.R | 42 ++++++++++++++++++++++--------
R/SeriesAggreg.list.R | 2 --
man/SeriesAggreg.Rd | 8 ++++--
tests/testthat/test-SeriesAggreg.R | 16 ++++++++++++
4 files changed, 53 insertions(+), 15 deletions(-)
diff --git a/R/SeriesAggreg.data.frame.R b/R/SeriesAggreg.data.frame.R
index ccdabba3..f963a054 100644
--- a/R/SeriesAggreg.data.frame.R
+++ b/R/SeriesAggreg.data.frame.R
@@ -51,15 +51,21 @@ SeriesAggreg.data.frame <- function(x,
if (length(ConvertFun) != (ncol(x) - 1)) {
stop(sprintf("'ConvertFun' must be of length %i (ncol(x)-1)", ncol(x) - 1))
}
- listConvertFun <- lapply(unique(ConvertFun), match.fun)
+ listConvertFun <- lapply(unique(ConvertFun), function(y) {
+ if (!grepl("^q\\d+$", y, ignore.case = TRUE)) {
+ return(match.fun(y))
+ }
+ })
names(listConvertFun) <- unique(ConvertFun)
lapply(ConvertFun, function(y) {
- TestOutput <- listConvertFun[[y]](1:10)
- if(!is.numeric(TestOutput)) {
- stop(sprintf("Returned value of '%s' function should be numeric", y))
- }
- if(length(TestOutput) != 1) {
- stop(sprintf("Returned value of '%s' function should be of length 1", y))
+ if (!grepl("^q\\d+$", y, ignore.case = TRUE)) {
+ TestOutput <- listConvertFun[[y]](1:10)
+ if(!is.numeric(TestOutput)) {
+ stop(sprintf("Returned value of '%s' function should be numeric", y))
+ }
+ if(length(TestOutput) != 1) {
+ stop(sprintf("Returned value of '%s' function should be of length 1", y))
+ }
}
})
@@ -146,10 +152,24 @@ SeriesAggreg.data.frame <- function(x,
listTsAggreg <- lapply(names(listConvertFun), function(y) {
if (any(ConvertFun == y)) {
colTsAggreg <- c("Fac2", colnames(x)[-1L][ConvertFun == y])
- aggregate(. ~ Fac2,
- data = TabSeries2[, colTsAggreg],
- FUN = listConvertFun[[y]],
- na.action = na.pass)
+ if (grepl("^q\\d+$", y, ignore.case = TRUE)) {
+ probs <- as.numeric(gsub("^q", "", y, ignore.case = TRUE)) / 100
+ if (probs < 0 || probs > 1) {
+ stop("'Q...' format of argument 'ConvertFun' must be an integer between 0 and 100")
+ }
+ aggregate(. ~ Fac2,
+ data = TabSeries2[, colTsAggreg],
+ FUN = quantile,
+ na.action = na.pass,
+ probs = probs,
+ type = 8,
+ na.rm = TRUE)
+ } else {
+ aggregate(. ~ Fac2,
+ data = TabSeries2[, colTsAggreg],
+ FUN = listConvertFun[[y]],
+ na.action = na.pass)
+ }
} else {
NULL
}
diff --git a/R/SeriesAggreg.list.R b/R/SeriesAggreg.list.R
index c9117e92..f7e3f3c0 100644
--- a/R/SeriesAggreg.list.R
+++ b/R/SeriesAggreg.list.R
@@ -104,8 +104,6 @@ SeriesAggreg.list <- function(x,
if (is.na(ConvertFun)) {
# Check for predefined ConvertFun for all sub-elements
listConvertFun <- .GetAggregConvertFun(names(listCols), Format)
- } else {
- listConvert
}
# Run SeriesAggreg for each embedded list
listRes <- lapply(names(listCols), function(y) {
diff --git a/man/SeriesAggreg.Rd b/man/SeriesAggreg.Rd
index c402a5eb..e5d871b7 100644
--- a/man/SeriesAggreg.Rd
+++ b/man/SeriesAggreg.Rd
@@ -25,6 +25,11 @@ Warning: on the aggregated outputs, the dates correspond to the beginning of the
\code{\link{SeriesAggreg.InputsModel}} and \code{\link{SeriesAggreg.OutputsModel}}
call \code{\link{SeriesAggreg.list}} which itself calls \code{\link{SeriesAggreg.data.frame}}.
So, all arguments passed to any \code{\link{SeriesAggreg}} method will be passed to \code{\link{SeriesAggreg.data.frame}}.
+
+ Argument \code{ConvertFun} also supports quantile calculation by using the syntax "Q[nn]" with [nn] the requested percentile.
+ E.g. use "Q90" for calculating 90th percentile in the aggregation.
+ The formula used is: \code{quantile(x, probs = perc / 100, type = 8, na.rm = TRUE)}.
+
}
@@ -62,7 +67,7 @@ Warning: on the aggregated outputs, the dates correspond to the beginning of the
\item{NewTimeFormat}{(deprecated) [character] output time step format (i.e. \code{"hourly"}, \code{"daily"}, \code{"monthly"} or \code{"yearly"}). Use the \code{Format} argument instead}
-\item{ConvertFun}{[character] names of aggregation functions (e.g. for P[mm], T[degC], Q[mm]: \code{ConvertFun = c("sum", "mean", "sum"})) or name of aggregation function to apply to all elements if the parameter 'x' is a [list]}
+\item{ConvertFun}{[character] names of aggregation functions (e.g. for P[mm], T[degC], Q[mm]: \code{ConvertFun = c("sum", "mean", "sum"})) or name of aggregation function to apply to all elements if the parameter 'x' is a [list] (See details)}
\item{YearFirstMonth}{(optional) [numeric] integer used when \code{Format = "\%Y"} to set when the starting month of the year (e.g. 01 for calendar year or 09 for hydrological year starting in September)}
@@ -77,7 +82,6 @@ Warning: on the aggregated outputs, the dates correspond to the beginning of the
\item{\dots}{Arguments passed to \code{\link{SeriesAggreg.list}} and then to \code{\link{SeriesAggreg.data.frame}}}
}
-
\value{
[POSIXct+numeric] data.frame containing a vector of aggregated dates (POSIXct) and time series values numeric)
}
diff --git a/tests/testthat/test-SeriesAggreg.R b/tests/testthat/test-SeriesAggreg.R
index 4d4d4907..c9edc42e 100644
--- a/tests/testthat/test-SeriesAggreg.R
+++ b/tests/testthat/test-SeriesAggreg.R
@@ -233,3 +233,19 @@ test_that("SeriesAggreg should work with ConvertFun 'min', 'max' and 'median'",
}
lapply(c("max", "min", "median"), function(x) {test_ConvertFunRegime(Qls, x, "%Y")})
})
+
+test_that("Error on convertFun Q without 0-100", {
+ Qls <- BasinObs[, c("DatesR", "Qls")]
+ expect_error(SeriesAggreg(Qls, "%Y", "q101"))
+ expect_error(SeriesAggreg(Qls, "%Y", "q-2"))
+ expect_error(SeriesAggreg(Qls, "%Y", "q12.5"))
+})
+
+test_that("ConvertFun q50 should be equal to median", {
+ Qls <- BasinObs[, c("DatesR", "Qls")]
+ expect_equal(SeriesAggreg(Qls, "%Y", "q50"),
+ SeriesAggreg(Qls, "%Y", "median"))
+ expect_equal(SeriesAggreg(Qls, "%Y", "q50"),
+ SeriesAggreg(Qls, "%Y", "q050"))
+})
+
--
GitLab