Commit 12c5247c authored by Dorchies David's avatar Dorchies David
Browse files

v1.6.8.18 feat: handle matrix and data.frame in SeriesAggreg.list for SD model

Refs #41
parent 3ae9b8e2
Pipeline #17976 passed with stages
in 11 minutes and 27 seconds
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.6.8.17
Version: 1.6.8.18
Date: 2020-12-01
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
......
SeriesAggreg.InputsModel <- function(TabSeries, ...) {
if (!inherits(TabSeries, "InputsModel")) {
stop("to be used with 'InputsModel' object")
}
res <- SeriesAggreg.list(TabSeries, except = "ZLayers", ...)
res <-
SeriesAggreg.list(TabSeries,
except = c("ZLayers", "LengthHydro", "BasinAreas"),
...)
return(res)
}
\ No newline at end of file
}
......@@ -9,14 +9,14 @@ SeriesAggreg.list <- function(TabSeries,
if (!is.list(TabSeries)) {
stop("to be used with a list")
}
if (missing(Format)) {
Format <- getSeriesAggregFormat(NewTimeFormat)
} else if (!is.null(NewTimeFormat)) {
warning("deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
call. = FALSE)
}
# Determination of DatesR
if (!is.null(TabSeries$DatesR)) {
if (!inherits(TabSeries$DatesR, "POSIXt")) {
......@@ -30,8 +30,7 @@ SeriesAggreg.list <- function(TabSeries,
inherits(x, "POSIXt")
}, simplify = TRUE))[1]
if (is.na(itemPOSIXt)) {
stop(
"At least one item of argument 'TabSeries' should be of class 'POSIXt'")
stop("At least one item of argument 'TabSeries' should be of class 'POSIXt'")
}
warning(
"Item 'DatesR' not found in 'TabSeries' argument: the item ",
......@@ -40,18 +39,19 @@ SeriesAggreg.list <- function(TabSeries,
)
DatesR <- TabSeries[[names(TabSeries)[itemPOSIXt]]]
}
# Selection of numeric items for aggregation
cols <- sapply(TabSeries, inherits, "numeric")
cols <- names(cols[which(cols)])
numericCols <- names(which(sapply(TabSeries, inherits, "numeric")))
arrayCols <- names(which(sapply(TabSeries, inherits, "array")))
numericCols <- setdiff(numericCols, arrayCols)
if (!is.null(except)) {
if (!inherits(except, "character")) {
stop("Argument 'except' should be a 'character'")
}
cols <- setdiff(cols, except)
numericCols <- setdiff(numericCols, except)
}
cols <- TabSeries[cols]
cols <- TabSeries[numericCols]
lengthCols <- sapply(cols, length, simplify = TRUE)
if (any(lengthCols != length(DatesR))) {
sErr <- paste0(names(lengthCols)[lengthCols != length(DatesR)],
......@@ -61,7 +61,7 @@ SeriesAggreg.list <- function(TabSeries,
"The length of the following `numeric` items in 'TabSeries' ",
"is different than the length of 'DatesR (",
length(DatesR),
")': ",
")': they will be ignored in the aggregation: ",
sErr
)
cols <- cols[lengthCols == length(DatesR)]
......@@ -81,11 +81,11 @@ SeriesAggreg.list <- function(TabSeries,
...,
ConvertFun = ConvertFun2)
}
if (simplify) {
# Returns data.frame of numeric found in the first level of the list
return(dfOut)
} else {
res <- list()
# Convert aggregated data.frame into list
......@@ -94,16 +94,17 @@ SeriesAggreg.list <- function(TabSeries,
## to be consistent with InputsModel class and because plot.OutputsModel use the POSIXlt class
res$DatesR <- as.POSIXlt(res$DatesR)
}
# 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")]
dfCols <-
c(dfCols, TabSeries[sapply(TabSeries, inherits, "matrix")])
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))
ConvertFun <- .AggregConvertFun(names(listCols))
# Run SeriesAggreg for each embedded list
listRes <-
lapply(names(listCols),
......@@ -119,28 +120,50 @@ SeriesAggreg.list <- function(TabSeries,
)
})
names(listRes) <- names(listCols)
if(is.null(res$DatesR)) {
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})
lapply(names(listRes), function(x) {
listRes[[x]]$DatesR <<- NULL
})
res <- c(res, listRes)
}
if (length(dfCols) > 0) {
# Processing matrix and dataframes
for (i in length(dfCols)) {
key <- names(dfCols)[i]
m <- dfCols[[i]]
if (nrow(m) != length(DatesR)) {
warning(
"The number of rows of the 'matrix' item ",
key, " (", nrow(m),
") is different than the length of 'DatesR ('", length(DatesR),
"), it will be ignored in the aggregation"
)
} else {
ConvertFun <- rep(.AggregConvertFun(key), ncol(m))
res[[key]] <- SeriesAggreg(data.frame(DatesR, m),
Format = Format,
ConvertFun = ConvertFun)
}
}
}
}
# 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
}
......@@ -26,7 +26,7 @@
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", "Qmm", "Qls", "E", "P"))
"LayerPrecip","LayerFracSolidPrecip", "Qmm", "Qls", "E", "P", "Qupstream"))
)
res <- sapply(Outputs, function(iOutputs) {
iRes <- Table$ConvertFun[Table$Outputs == iOutputs]
......
......@@ -141,10 +141,14 @@ test_that("Check SeriesAggreg.outputsModel", {
which(format(BasinObs$DatesR, format = "%Y-%m-%d") == "1999-12-31"))
## preparation of the RunOptions object
RunOptions <-
CreateRunOptions(FUN_MOD = RunModel_CemaNeigeGR4J,
InputsModel = InputsModel,
IndPeriod_Run = Ind_Run)
suppressWarnings(
RunOptions <-
CreateRunOptions(
FUN_MOD = RunModel_CemaNeigeGR4J,
InputsModel = InputsModel,
IndPeriod_Run = Ind_Run
)
)
## simulation
Param <- c(
......@@ -164,3 +168,25 @@ test_that("Check SeriesAggreg.outputsModel", {
expect_equal(length(O2$DatesR),
length(O2$CemaNeigeLayers$Layer01$Pliq))
})
test_that("Check data.frame handling in SeriesAggreg.list", {
QObsUp <- imputeTS::na_interpolation(BasinObs$Qmm)
InputsModelDown1 <- CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E,
Qupstream = matrix(QObsUp, ncol = 1),
# Upstream observed flow
LengthHydro = 100 * 1000,
# Distance between upstream catchment outlet and the downstream one in m
BasinAreas = c(180, 180) # Upstream and downstream areas in km²
)
expect_warning(SeriesAggreg(InputsModelDown1, "%Y%m"),
regexp = NA)
I2 <- SeriesAggreg(InputsModelDown1, "%Y%m")
expect_equal(length(I2$DatesR), nrow(I2$Qupstream))
InputsModelDown1$Qupstream <- InputsModelDown1$Qupstream[-1, , drop=FALSE] # https://stackoverflow.com/a/7352287/5300212
expect_warning(SeriesAggreg(InputsModelDown1, "%Y%m"),
regexp = "it will be ignored in the aggregation")
})
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