Commit 958511fb authored by Dorchies David's avatar Dorchies David
Browse files

v1.6.8.15 feat: embedded lists handling in SeriesAggreg

Refs #41
parent b3fa3fe2
Pipeline #17959 passed with stages
in 46 minutes and 18 seconds
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.6.8.14
Date: 2020-11-24
Version: 1.6.8.15
Date: 2020-11-30
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
person("Olivier", "Delaigue", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-7668-8468"), email = "airGR@inrae.fr"),
......
......@@ -3,11 +3,7 @@ SeriesAggreg.InputsModel <- function(TabSeries, ...) {
if (!inherits(TabSeries, "InputsModel")) {
stop("to be used with 'InputsModel' object")
}
res <- SeriesAggreg.list(TabSeries, ...)
if (inherits(TabSeries, "CemaNeige")) {
res$ZLayers <- TabSeries$ZLayers
}
res <- SeriesAggreg.list(TabSeries, except = "ZLayers", ...)
return(res)
......
SeriesAggreg.list <- function(TabSeries, Format, simplify = FALSE, NewTimeFormat = NULL, ...) {
SeriesAggreg.list <- function(TabSeries,
Format,
ConvertFun,
NewTimeFormat = NULL,
simplify = FALSE,
DatesR = NULL,
except = NULL,
recursive = TRUE,
...) {
if (!is.list(TabSeries)) {
stop("to be used with a list")
}
if(missing(Format)) {
if (missing(Format)) {
Format <- getSeriesAggregFormat(NewTimeFormat)
} else if (!is.null(NewTimeFormat)) {
warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
call. = FALSE)
}
# Search for input date time series
if (!inherits(TabSeries, "GR") & inherits(TabSeries, "CemaNeige")) {
ClassTabSeries <- class(TabSeries)
zzz <- list(zzz = rep(NaN, length(TabSeries$DatesR)))
TabSeries <- append(TabSeries, values = zzz, after = 1)
class(TabSeries) <- ClassTabSeries
lastCol <- "zzz"
# Determination of DateR
# 'DatesR' is explicitly provided by argument 'DatesR'
bDatesR <- !is.null(DatesR)
if (bDatesR) {
if (inherits(DatesR, "character")) {
DatesR <- DatesR[1]
if (!is.null(TabSeries[[DatesR]])) {
DatesR <- TabSeries[[DatesR]]
} else {
stop(
"The item selected by the argument 'DatesR'='",
DatesR,
"' should exist in 'TabSeries'"
)
}
} else {
if (!inherits(DatesR, "POSIXt")) {
stop("Argument 'DatesR' should be of class 'POSIXt' or 'character'")
}
}
}
# If available, we take 'DatesR' item in 'TabSeries'
if (is.null(DatesR)) {
if (!is.null(TabSeries$DatesR)) {
DatesR <- TabSeries$DatesR
}
}
if (inherits(TabSeries, "GR")) {
if (inherits(TabSeries, "InputsModel")) {
lastCol <- "PotEvap"
# Auto-detection of POSIXt item in Tabseries
if (!is.null(DatesR)) {
if (!inherits(DatesR, "POSIXt")) {
stop("'DatesR' should be of class 'POSIXt'")
}
if (inherits(TabSeries, "OutputsModel")) {
lastCol <- "Qsim"
} else {
itemPOSIXt <-
which(sapply(TabSeries, function(x) {
inherits(x, "POSIXt")
}, simplify = TRUE))[1]
if (is.na(itemPOSIXt)) {
stop(
"One item of argument 'TabSeries' should be of class 'POSIXt' ",
"or the dates should be provided by the 'DatesR' argument"
)
}
warning(
"Item 'DatesR' not found in 'TabSeries' argument and no argument 'DatesR' ",
"provided. The item ",
names(TabSeries)[itemPOSIXt],
" has been automatically chosen"
)
DatesR <- TabSeries[[names(TabSeries)[itemPOSIXt]]]
}
if (inherits(TabSeries, "CemaNeige")) {
if (inherits(TabSeries, "InputsModel")) {
CemaNeigeLayers <- TabSeries[grep("^Layer", names(TabSeries))]
CemaNeigeLayers <- lapply(seq_along(CemaNeigeLayers), function(iLayer) {
tmp <- CemaNeigeLayers[[iLayer]]
names(tmp) <- paste(names(CemaNeigeLayers)[iLayer], names(tmp), sep = ".")
tmp
})
names(CemaNeigeLayers) <- grep("^Layer", names(TabSeries), value = TRUE)
# Selection of numeric items for aggregation
cols <- sapply(TabSeries, inherits, "numeric")
cols <- names(cols[which(cols)])
if (!is.null(except)) {
if (!inherits(except, "character")) {
stop("Argument 'except' should be a 'character'")
}
if (inherits(TabSeries, "OutputsModel") ){
CemaNeigeLayers <- TabSeries$CemaNeigeLayers
cols <- setdiff(cols, except)
}
cols <- TabSeries[cols]
lengthCols <- sapply(cols, length, simplify = TRUE)
if (any(lengthCols != length(DatesR))) {
sErr <- paste0(names(lengthCols)[lengthCols != length(DatesR)],
" (", lengthCols[lengthCols != length(DatesR)], ")",
collapse = ", ")
warning(
"The length of the following `numeric` items in 'TabSeries' ",
"is different than the length of 'DatesR (",
length(DatesR),
")': ",
sErr
)
cols <- cols[lengthCols == length(DatesR)]
}
dfOut <- NULL
if (length(cols)) {
ConvertFun2 <- .AggregConvertFun(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))
}
}
CemaNeigeLayersAggreg <- lapply(CemaNeigeLayers, function(iLayer) {
tmp <- cbind(TabSeries$DatesR, as.data.frame(iLayer))
res <- SeriesAggreg(tmp, Format, ..., ConvertFun = .AggregConvertFun(gsub("[.].*", "", colnames(tmp)[-1L])))
res <- res[, -1L]
colnames(res) <- gsub(".*[.]", "", colnames(res))
res <- as.list(res)
})
dfOut <- SeriesAggreg(cbind(DatesR, as.data.frame(cols)),
Format,
...,
ConvertFun = ConvertFun2)
}
TabSeries2 <- TabSeries[1:which(names(TabSeries) %in% lastCol)]
TabSeries2 <- as.data.frame.list(TabSeries2)
NewTabSeries <- SeriesAggreg(TabSeries = TabSeries2, Format, ..., ConvertFun = .AggregConvertFun(colnames(TabSeries2)[-1L]))
NewTabSeries$zzz <- NULL
if (simplify) {
return(NewTabSeries)
# Returns data.frame of numeric found in the first level of the list
return(dfOut)
} else {
res <- list()
# Convert aggregated data.frame into list
if (!is.null(dfOut)) {
res <- as.list(dfOut)
## to be consistent with InputsModel class and because plot.OutputsModel use the POSIXlt class
res$DatesR <- as.POSIXlt(res$DatesR)
}
ClassFormat <- switch(substr(Format, start = nchar(Format), stop = nchar(Format)),
h = "hourly",
d = "daily",
m = "monthly",
Y = "yearly")
## to be consistent with InputsModel class and because plot.OutputsModel use the POSIXlt class
NewTabSeries$DatesR <- as.POSIXlt(NewTabSeries$DatesR)
res <- as.list(NewTabSeries)
if (inherits(TabSeries, "CemaNeige")) {
if (inherits(TabSeries, "InputsModel")) {
res <- c(NewTabSeries, CemaNeigeLayersAggreg)
}
if (inherits(TabSeries, "OutputsModel")) {
res$CemaNeigeLayers <- CemaNeigeLayersAggreg
# Exploration of embedded lists and data.frames
if (is.null(recursive) || recursive) {
listCols <- TabSeries[sapply(TabSeries, inherits, "list")]
dfCols <- TabSeries[sapply(TabSeries, inherits, "data.frame")]
listCols <- listCols[setdiff(names(listCols), names(dfCols))]
if (length(listCols) > 0) {
# Check for predefined ConvertFun for all sub-elements
ConvertFun <-
unlist(lapply(names(listCols), .AggregConvertFun))
# Run SeriesAggreg for each embedded list
listRes <-
lapply(names(listCols),
function(x) {
SeriesAggreg(
listCols[[x]],
Format = Format,
DatesR = DatesR,
except = except,
ConvertFun = ConvertFun[x],
recursive = NULL,
...
)
})
names(listRes) <- names(listCols)
if(is.null(res$DatesR)) {
# Copy DatesR in top level list
res$DatesR <- listRes[[1]]$DatesR
}
# Remove DatesR in embedded lists
lapply(names(listRes), function(x) {listRes[[x]]$DatesR <<- NULL})
res <- c(res, listRes)
}
# res <- append(res, CemaNeigeLayersAggreg, after = length(res))
}
class(res) <- gsub("hourly|daily|monthly|yearly", ClassFormat, class(TabSeries))
# Store elements that are not aggregated
res <- c(res, TabSeries[setdiff(names(TabSeries), names(res))])
class(res) <-
gsub(
"hourly|daily|monthly|yearly",
getSeriesAggregClass(Format),
class(TabSeries)
)
return(res)
}
}
\ No newline at end of file
......@@ -21,12 +21,12 @@
Table <- rbind(
data.frame(ConvertFun = "mean",
Outputs = c("Prod","Rout","Exp","SnowPack","ThermalState",
"Gratio","Temp","Gthreshold","Glocalmax","LayerTempMean")),
"Gratio","Temp","Gthreshold","Glocalmax","LayerTempMean", "T")),
data.frame(ConvertFun = "sum",
Outputs = c("zzz","PotEvap","Precip","Pn","Ps","AE","Perc","PR","Q9",
"Q1","Exch","AExch1","AExch2","AExch","QR","QRExp",
"QD","Qsim","Pliq","Psol","PotMelt","Melt","PliqAndMelt",
"LayerPrecip","LayerFracSolidPrecip"))
"LayerPrecip","LayerFracSolidPrecip", "Qmm", "Qls", "E", "P"))
)
res <- sapply(Outputs, function(iOutputs) {
iRes <- Table$ConvertFun[Table$Outputs == iOutputs]
......
......@@ -28,4 +28,16 @@ getSeriesAggregFormat <- function(NewTimeFormat) {
return(Format)
}
return(NULL)
}
getSeriesAggregClass <- function(Format) {
switch(
substr(Format,
start = nchar(Format),
stop = nchar(Format)),
h = "hourly",
d = "daily",
m = "monthly",
Y = "yearly"
)
}
\ No newline at end of file
......@@ -33,7 +33,14 @@ Format, ConvertFun, TimeFormat = NULL, NewTimeFormat = NULL,
YearFirstMonth = 1, TimeLag = 0, \dots)
\method{SeriesAggreg}{list}(TabSeries,
Format, simplify = FALSE, NewTimeFormat = NULL, \dots)
Format,
ConvertFun,
NewTimeFormat = NULL,
simplify = FALSE,
DatesR = NULL,
except = NULL,
recursive = TRUE,
\dots)
\method{SeriesAggreg}{InputsModel}(TabSeries, \dots)
......@@ -42,7 +49,7 @@ Format, simplify = FALSE, NewTimeFormat = NULL, \dots)
\arguments{
\item{TabSeries}{[POSIXt+numeric] data.frame containing the vector of dates (POSIXt) and the time series values numeric)}
\item{TabSeries}{[InputsModel], [OutputsModel], [list] or [data.frame] containing the vector of dates (POSIXt) and the time series of numeric values}
\item{Format}{[character] output time step format (i.e. yearly times series: \code{"\%Y"}, monthly time series: \code{"\%Y\%m"}, daily time series: \code{"\%Y\%m\%d"}, monthly regimes \code{"\%m"}, daily regimes \code{"\%d"})}
......@@ -58,6 +65,12 @@ Format, simplify = FALSE, NewTimeFormat = NULL, \dots)
\item{simplify}{(optional) [boolean] if set to \code{TRUE}, a \code{\link{data.frame}} is returned instead of a \code{\link{list}}. Embedded lists are then ignored. Default = \code{FALSE}}
\item{DatesR}{(optional) [POSIXt] with the vector of dates if the dates are not provided in the argument \code{TabSeries}.}
\item{except}{(optional) [character] the name of the items to skip in the aggregation (default: \code{NULL})}
\item{recursive}{(optional) [boolean] if set to \code{FALSE}, embedded lists and dataframes are not aggregated (Default \code{TRUE})}
\item{\dots}{Arguments passed to \code{\link{SeriesAggreg.list}} and then to \code{\link{SeriesAggreg.data.frame}}}
}
......
......@@ -65,12 +65,52 @@ test_that("Check SeriesAggreg output values on yearly aggregation", {
E = BasinObs$E,
Qmm = BasinObs$Qmm
)
GoodValues <- apply(
BasinObs[BasinObs$DatesR >= "1984-09-01" & BasinObs$DatesR < "1985-09-01",
c("P", "E", "Qmm")], 2, sum)
TestedValues <- unlist(SeriesAggreg(TabSeries,
Format = "%Y",
ConvertFun = rep("sum", 3),
YearFirstMonth = 9)[1, c("P", "E", "Qmm")])
GoodValues <- apply(BasinObs[BasinObs$DatesR >= "1984-09-01" &
BasinObs$DatesR < "1985-09-01",
c("P", "E", "Qmm")], 2, sum)
TestedValues <- unlist(SeriesAggreg(
TabSeries,
Format = "%Y",
ConvertFun = rep("sum", 3),
YearFirstMonth = 9
)[1, c("P", "E", "Qmm")])
expect_equal(GoodValues, TestedValues)
})
test_that("Check SeriesAggreg.list 'DatesR' argument", {
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
DatesR <- InputsModel$DatesR
# No InputsModel$DatesR
InputsModel$DatesR <- NULL
expect_error(SeriesAggreg(InputsModel, "%Y%m"), regexp = "'POSIXt'")
# Other list item chosen
InputsModel$SuperDates <- DatesR
expect_warning(SeriesAggreg(InputsModel, "%Y%m"), regexp = "SuperDates")
# Wrong InputsModel$DatesR
InputsModel$DatesR <- BasinObs$P
expect_error(SeriesAggreg(InputsModel, "%Y%m"), regexp = "'POSIXt'")
})
test_that("Check SeriesAggreg.list with embedded lists", {
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_CemaNeige,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
TempMean = BasinObs$T,
ZInputs = BasinInfo$HypsoData[51],
HypsoData = BasinInfo$HypsoData,
NLayers = 5
)
I2 <- SeriesAggreg(InputsModel, "%Y%m")
expect_equal(length(I2$ZLayers), 5)
expect_null(I2$LayerPrecip$DatesR)
expect_equal(length(I2$DatesR), length(I2$LayerPrecip$L1))
})
\ No newline at end of file
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