diff --git a/R/SeriesAggreg.InputsModel.R b/R/SeriesAggreg.InputsModel.R
index a6414fb823235d3fb19904602adcd8a177b82466..4a62b4ec57f386dac597ca91c5e087853d2b9660 100644
--- a/R/SeriesAggreg.InputsModel.R
+++ b/R/SeriesAggreg.InputsModel.R
@@ -1,6 +1,7 @@
-SeriesAggreg.InputsModel <- function(x, ...) {
+SeriesAggreg.InputsModel <- function(x, Format, ...) {
SeriesAggreg.list(x,
- ConvertFun = .GetAggregConvertFun(names(x)),
+ Format,
+ ConvertFun = .GetAggregConvertFun(names(x), Format),
except = c("ZLayers", "LengthHydro", "BasinAreas"),
...)
}
diff --git a/R/SeriesAggreg.OutputsModel.R b/R/SeriesAggreg.OutputsModel.R
index 264bd5b7fb7f41e226004ce244d545246eefe881..27eb2ff3e7f985309668463a3d2ff3602c97cf2b 100644
--- a/R/SeriesAggreg.OutputsModel.R
+++ b/R/SeriesAggreg.OutputsModel.R
@@ -1,6 +1,7 @@
-SeriesAggreg.OutputsModel <- function(x, ...) {
+SeriesAggreg.OutputsModel <- function(x, Format, ...) {
SeriesAggreg.list(x,
- ConvertFun = .GetAggregConvertFun(names(x)),
+ Format,
+ ConvertFun = .GetAggregConvertFun(names(x), Format),
except = "StateEnd",
...)
}
diff --git a/R/SeriesAggreg.data.frame.R b/R/SeriesAggreg.data.frame.R
index 1761ba9ac234980e3fd5f58b16860174c53aefe9..ccdabba3514d57ddd97583213d6b1147f9d3c191 100644
--- a/R/SeriesAggreg.data.frame.R
+++ b/R/SeriesAggreg.data.frame.R
@@ -48,14 +48,21 @@ SeriesAggreg.data.frame <- function(x,
Format <- match.arg(Format, choices = listFormat)
## check ConvertFun
- listConvertFun <- list(sum = sum, mean = mean)
- ConvertFun <- names(listConvertFun)[match(ConvertFun, names(listConvertFun))]
- if (anyNA(ConvertFun)) {
- stop("'ConvertFun' should be a one of 'sum' or 'mean'")
- }
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)
+ 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))
+ }
+ })
+
## check YearFirstMonth
msgYearFirstMonth <- "'YearFirstMonth' should be a single vector of numeric value between 1 and 12"
YearFirstMonth <- match(YearFirstMonth, 1:12)
@@ -135,9 +142,7 @@ SeriesAggreg.data.frame <- function(x,
}
TabSeries2$Fac2 <- TabSeries2$Selec2
TabSeries2$Selec <- !duplicated(TabSeries2$Selec2)
- ConvertFun <- rep("mean", ncol(x) - 1)
}
-
listTsAggreg <- lapply(names(listConvertFun), function(y) {
if (any(ConvertFun == y)) {
colTsAggreg <- c("Fac2", colnames(x)[-1L][ConvertFun == y])
diff --git a/R/SeriesAggreg.list.R b/R/SeriesAggreg.list.R
index 8834347dbc5ac40fa35a5c19b074699173c34f15..299bce021255cd010d6616905aaa201c509a55bc 100644
--- a/R/SeriesAggreg.list.R
+++ b/R/SeriesAggreg.list.R
@@ -59,7 +59,7 @@ SeriesAggreg.list <- function(x,
}
dfOut <- NULL
if (length(cols)) {
- ConvertFun2 <- .GetAggregConvertFun(names(cols))
+ ConvertFun2 <- .GetAggregConvertFun(names(cols), Format)
if (is.null(recursive)) {
if (missing(ConvertFun)) {
stop("'ConvertFun' argument should provided if 'recursive = NULL'")
@@ -94,7 +94,7 @@ SeriesAggreg.list <- function(x,
listCols <- listCols[setdiff(names(listCols), names(dfCols))]
if (length(listCols) > 0) {
# Check for predefined ConvertFun for all sub-elements
- ConvertFun <- .GetAggregConvertFun(names(listCols))
+ ConvertFun <- .GetAggregConvertFun(names(listCols), Format)
# Run SeriesAggreg for each embedded list
listRes <- lapply(names(listCols), function(x) {
listCols[[x]]$DatesR <- DatesR
@@ -129,7 +129,7 @@ SeriesAggreg.list <- function(x,
"), it will be ignored in the aggregation"
)
} else {
- ConvertFun <- rep(.GetAggregConvertFun(key), ncol(m))
+ ConvertFun <- rep(.GetAggregConvertFun(key, Format), ncol(m))
res[[key]] <- SeriesAggreg(data.frame(DatesR, m),
Format = Format,
ConvertFun = ConvertFun)
diff --git a/R/UtilsSeriesAggreg.R b/R/UtilsSeriesAggreg.R
index d610b03b9aa8a3e9ae278087ea8afb59d8b9aee9..9b47efac0bdc70bd1cabbf3cf6db3e6ed1c0603e 100644
--- a/R/UtilsSeriesAggreg.R
+++ b/R/UtilsSeriesAggreg.R
@@ -36,7 +36,7 @@
Y = "yearly")
}
-.GetAggregConvertFun <- function(x) {
+.GetAggregConvertFun <- function(x, Format) {
AggregConvertFunTable <- rbind(
data.frame(ConvertFun = "mean",
x = c("Prod", "Rout", "Exp", "SnowPack", "ThermalState",
@@ -53,5 +53,8 @@
iRes <- AggregConvertFunTable$ConvertFun[AggregConvertFunTable$x == iX]
iRes <- ifelse(test = any(is.na(iRes)), yes = NA, no = iRes) # R < 4.0 compatibility
})
+ if(Format %in% c("%d", "%m")) {
+ res <- rep("mean", length(res))
+ }
return(res)
}
diff --git a/man/SeriesAggreg.Rd b/man/SeriesAggreg.Rd
index 2c095b545f4e10a5fb985e31a4e55c35fec73d69..aa7e67fd36c285861b783cd3c391a6fe61913fc1 100644
--- a/man/SeriesAggreg.Rd
+++ b/man/SeriesAggreg.Rd
@@ -47,9 +47,9 @@ Warning: on the aggregated outputs, the dates correspond to the beginning of the
recursive = TRUE,
\dots)
-\method{SeriesAggreg}{InputsModel}(x, \dots)
+\method{SeriesAggreg}{InputsModel}(x, Format, \dots)
-\method{SeriesAggreg}{OutputsModel}(x, \dots)
+\method{SeriesAggreg}{OutputsModel}(x, Format, \dots)
}
diff --git a/tests/testthat/helper_seriesaggreg.R b/tests/testthat/helper_seriesaggreg.R
new file mode 100644
index 0000000000000000000000000000000000000000..e09bc4a13acc22649c814db7de46096010e23377
--- /dev/null
+++ b/tests/testthat/helper_seriesaggreg.R
@@ -0,0 +1,3 @@
+sample2 <- function(x) {sample(x, 2)}
+
+stringFunction <- function(x) {format(max(x))}
diff --git a/tests/testthat/test-SeriesAggreg.R b/tests/testthat/test-SeriesAggreg.R
index f71db81857c4531093ed3c6d123dcbea053dfe45..ce5cf87610b64ddcebe084d883b3ea8acba54547 100644
--- a/tests/testthat/test-SeriesAggreg.R
+++ b/tests/testthat/test-SeriesAggreg.R
@@ -71,6 +71,18 @@ test_that("Check SeriesAggreg output values on yearly aggregation", {
expect_equal(GoodValues, TestedValues)
})
+test_that("Regime calculation should switch ConvertFun to 'mean' for InputsModel", {
+ InputsModel <- CreateInputsModel(
+ FUN_MOD = RunModel_GR4J,
+ DatesR = BasinObs$DatesR,
+ Precip = BasinObs$P,
+ PotEvap = BasinObs$E
+ )
+
+ expect_equal(SeriesAggreg(InputsModel, "%m")$Precip,
+ SeriesAggreg(BasinObs[, c("DatesR", "P")], "%m", ConvertFun = "mean")$P)
+})
+
test_that("No DatesR should warning", {
TabSeries <- list(
Dates = BasinObs$DatesR,
@@ -187,6 +199,7 @@ test_that("Check data.frame handling in SeriesAggreg.list", {
expect_warning(SeriesAggreg(InputsModelDown1, "%Y%m"),
regexp = "it will be ignored in the aggregation")
})
+
test_that("SeriesAggreg from and to the same time step should return initial time series", {
InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J,
@@ -198,6 +211,7 @@ test_that("SeriesAggreg from and to the same time step should return initial tim
expect_warning(SeriesAggreg(I2, "%Y%m"), regexp = "No time-step conversion was performed")
expect_equal(I2, suppressWarnings(SeriesAggreg(I2, "%Y%m")))
})
+
test_that("SeriesAggreg.data.frame with first column not named DatesR should work",
{
expect_warning(SeriesAggreg(
@@ -207,3 +221,20 @@ test_that("SeriesAggreg.data.frame with first column not named DatesR should wor
),
regexp = NA)
})
+
+test_that("SeriesAggreg should work with ConvertFun 'min', 'max' and 'median'", {
+ Qls <- BasinObs[, c("DatesR", "Qls")]
+ test_ConvertFunRegime <- function(x, ConvertFun, TimeFormat) {
+ expect_equal(nrow(SeriesAggreg(x, TimeFormat, ConvertFun = ConvertFun)),
+ length(unique(format(BasinObs$DatesR, "%Y"))))
+ }
+ lapply(c("max", "min", "median"), function(x) {test_ConvertFunRegime(Qls, x, "%Y")})
+})
+
+test_that("Error on wrong aggregation function", {
+ Qls <- BasinObs[, c("DatesR", "Qls")]
+ expect_error(SeriesAggreg(Qls, "%Y", ConvertFun = "sample2"),
+ regexp = "should be of length 1")
+ expect_error(SeriesAggreg(Qls, "%Y", ConvertFun = "stringFunction"),
+ regexp = "should be numeric")
+})