feat: open SeriesAggreg to any function

- Remove restriction to "mean" and "sum" only
- Manage regime calculation in .GetAggregConvertFun
- Add corresponding tests
- Change signature functions in documentation

R/SeriesAggreg.InputsModel.R

-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"),
                     ...)
 }

R/SeriesAggreg.OutputsModel.R

-SeriesAggreg.OutputsModel <- function(x, ...) {
+SeriesAggreg.OutputsModel <- function(x, Format, ...) {
   SeriesAggreg.list(x,
-                    ConvertFun = .GetAggregConvertFun(names(x)),
+                    Format,
+                    ConvertFun = .GetAggregConvertFun(names(x), Format),
                     except = "StateEnd",
                     ...)
 }

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])

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)

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)
 }

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)
 }
 
 

tests/testthat/helper_seriesaggreg.R

+sample2 <- function(x) {sample(x, 2)}
+
+stringFunction <- function(x) {format(max(x))}

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")
+})