Commit 192931c7 authored by Dorchies David's avatar Dorchies David
Browse files

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
parent b7316fed
Pipeline #18995 failed with stages
in 12 minutes and 32 seconds
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"),
...)
}
SeriesAggreg.OutputsModel <- function(x, ...) {
SeriesAggreg.OutputsModel <- function(x, Format, ...) {
SeriesAggreg.list(x,
ConvertFun = .GetAggregConvertFun(names(x)),
Format,
ConvertFun = .GetAggregConvertFun(names(x), Format),
except = "StateEnd",
...)
}
......@@ -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])
......
......@@ -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)
......
......@@ -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)
}
......@@ -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)
}
......
sample2 <- function(x) {sample(x, 2)}
stringFunction <- function(x) {format(max(x))}
......@@ -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")
})
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment