Merge branch '82-add-min-max-and-median-function-in-seriesaggreg' into 'dev'

Resolve "Opening of usable functions in SeriesAggreg"

Closes #82

See merge request !25

R/SeriesAggreg.InputsModel.R

-SeriesAggreg.InputsModel <- function(x, ...) {
+SeriesAggreg.InputsModel <- function(x, Format, ...) {
   SeriesAggreg.list(x,
-                    ConvertFun = .GetAggregConvertFun(names(x)),
+                    Format,
+                    ConvertFun = NA,
                     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 = NA,
                     except = "StateEnd",
                     ...)
 }

R/SeriesAggreg.data.frame.R

@@ -48,14 +48,27 @@ 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), function(y) {
+    if (!grepl("^q\\d+$", y, ignore.case = TRUE)) {
+      return(match.fun(y))
+    }
+  })
+  names(listConvertFun) <- unique(ConvertFun)
+  lapply(ConvertFun, function(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))
+      }
+    }
+  })
+
   ## check YearFirstMonth
   msgYearFirstMonth <- "'YearFirstMonth' should be a single vector of numeric value between 1 and 12"
   YearFirstMonth <- match(YearFirstMonth, 1:12)
@@ -135,16 +148,28 @@ 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])
-      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
     }

R/SeriesAggreg.list.R

@@ -16,6 +16,16 @@ SeriesAggreg.list <- function(x,
     warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
             call. = FALSE)
   }
+  # Check ConvertFun
+  if (any(class(x) %in% c("InputsModel", "OutputsModel"))) {
+    if (!all(is.na(ConvertFun))) {
+      warning("Argument 'ConvertFun' is ignored on 'InputsModel' and 'OutputsModel' objects")
+    }
+  } else if (length(ConvertFun)!=1) {
+    stop("Argument 'ConvertFun' must be of length 1 with 'list' object")
+  } else if (!is.character(ConvertFun)) {
+    stop("Argument 'ConvertFun' must be a character")
+  }
 
   # Determination of DatesR
   if (!is.null(x$DatesR)) {
@@ -63,13 +73,11 @@ SeriesAggreg.list <- function(x,
   }
   dfOut <- NULL
   if (length(cols)) {
-    ConvertFun2 <- .GetAggregConvertFun(names(cols))
-    if (is.null(recursive)) {
-      if (missing(ConvertFun)) {
-        stop("'ConvertFun' argument should provided if 'recursive = NULL'")
-      } else if (!is.na(ConvertFun)) {
-        ConvertFun2 <- rep(ConvertFun, length(cols))
-      }
+    # Treating aggregation at root level
+    if (is.na(ConvertFun)) {
+      ConvertFun2 <- .GetAggregConvertFun(names(cols), Format)
+    } else {
+      ConvertFun2 <- rep(ConvertFun, length(cols))
     }
     dfOut <- SeriesAggreg(cbind(DatesR, as.data.frame(cols)),
                           Format,
@@ -97,17 +105,25 @@ SeriesAggreg.list <- function(x,
       dfCols <- c(dfCols, x[sapply(x, inherits, "matrix")])
       listCols <- listCols[setdiff(names(listCols), names(dfCols))]
       if (length(listCols) > 0) {
-        # Check for predefined ConvertFun for all sub-elements
-        ConvertFun <- .GetAggregConvertFun(names(listCols))
+        if (is.na(ConvertFun)) {
+          # Check for predefined ConvertFun for all sub-elements
+          listConvertFun <- .GetAggregConvertFun(names(listCols), Format)
+        }
         # Run SeriesAggreg for each embedded list
-        listRes <- lapply(names(listCols), function(x) {
-          listCols[[x]]$DatesR <- DatesR
-          SeriesAggreg(listCols[[x]],
+        listRes <- lapply(names(listCols), function(y) {
+          listCols[[y]]$DatesR <- DatesR
+          if (is.na(ConvertFun)) {
+            SeriesAggreg.list(listCols[[y]],
                        Format = Format,
-                       except = except,
-                       ConvertFun = ConvertFun[x],
                        recursive = NULL,
-                       ...)
+                       ...,
+                       ConvertFun = listConvertFun[y])
+          } else {
+            SeriesAggreg.list(listCols[[y]],
+                              Format = Format,
+                              recursive = NULL,
+                              ...)
+          }
         })
         names(listRes) <- names(listCols)
         if (is.null(res$DatesR)) {
@@ -133,10 +149,14 @@ SeriesAggreg.list <- function(x,
               "), it will be ignored in the aggregation"
             )
           } else {
-            ConvertFun <- rep(.GetAggregConvertFun(key), ncol(m))
-            res[[key]] <- SeriesAggreg(data.frame(DatesR, m),
+            if (is.na(ConvertFun)) {
+              ConvertFun2 <- rep(.GetAggregConvertFun(key, Format), ncol(m))
+            } else {
+              ConvertFun2 <- rep(ConvertFun, ncol(m))
+            }
+            res[[key]] <- SeriesAggreg.data.frame(data.frame(DatesR, m),
                                        Format = Format,
-                                       ConvertFun = ConvertFun)
+                                       ConvertFun = ConvertFun2)
           }
         }
       }

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

@@ -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)}.
+
 }
 
 
@@ -47,9 +52,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)
 }
 
 
@@ -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"})) (default: use the name of the column (see details) or \code{"mean"} for regime calculation)}
+\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)
 }

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,
@@ -78,7 +90,10 @@ test_that("No DatesR should warning", {
     E = BasinObs$E,
     Qmm = BasinObs$Qmm
   )
-  expect_warning(SeriesAggreg(TabSeries, "%Y%m"), regexp = "has been automatically chosen")
+  expect_warning(
+    SeriesAggreg(TabSeries, "%Y%m", ConvertFun = "sum"),
+    regexp = "has been automatically chosen"
+  )
 })
 
 test_that("Check SeriesAggreg.list 'DatesR' argument", {
@@ -187,6 +202,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 +214,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 +224,28 @@ 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 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"))
+})
+