Skip to content

GitLab

Commit c27f77f5 authored by Dorchies David's avatar Dorchies David
Browse files

v1.6.8.21 refactor(SeriesAggreg): Change 'TabSeries' argument to 'x' argument 

- remove useless test of class compatibility in SeriesAggreg methods
- Change R compatibility to R >= 3.1.0 because of anyNA

Refs #41
parent f698eb68
Pipeline #17999 passed with stages
in 12 minutes and 23 seconds
Hide whitespace changes
Inline Side-by-side
.Rbuildignore
View file @ c27f77f5
......@@ -7,3 +7,4 @@
^\.regressionignore$
^\.gitlab-ci\.yml$
^\.vscode$
^Rplots\.pdf$
DESCRIPTION
View file @ c27f77f5
Package: airGR
Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.6.8.20
Version: 1.6.8.21
Date: 2020-12-01
Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
......@@ -20,7 +20,7 @@ Authors@R: c(
person("Raji", "Pushpalatha", role = c("ctb")),
person("Audrey", "Valéry", role = c("ctb"))
)
Depends: R (>= 3.0.1)
Depends: R (>= 3.1.0)
Suggests: knitr, rmarkdown, coda, DEoptim, dplyr, FME, ggmcmc, hydroPSO, Rmalschains, testthat, imputeTS
Description: Hydrological modelling tools developed at INRAE-Antony (HYCAR Research Unit, France). The package includes several conceptual rainfall-runoff models (GR4H, GR5H, GR4J, GR5J, GR6J, GR2M, GR1A), a snow accumulation and melt model (CemaNeige) and the associated functions for their calibration and evaluation. Use help(airGR) for package description and references.
License: GPL-2
......
R/SeriesAggreg.InputsModel.R
View file @ c27f77f5
SeriesAggreg.InputsModel <- function(TabSeries, ...) {
if (!inherits(TabSeries, "InputsModel")) {
stop("to be used with 'InputsModel' object")
}
res <-
SeriesAggreg.list(TabSeries,
except = c("ZLayers", "LengthHydro", "BasinAreas"),
...)
SeriesAggreg.InputsModel <- function(x, ...) {
res <- SeriesAggreg.list(x,
except = c("ZLayers", "LengthHydro", "BasinAreas"),
...)
return(res)
}
R/SeriesAggreg.OutputsModel.R
View file @ c27f77f5
SeriesAggreg.OutputsModel <- function(TabSeries, ...) {
if (!inherits(TabSeries, "OutputsModel")) {
stop("to be used with 'OutputsModel' object")
}
res <- SeriesAggreg.list(TabSeries, except = "StateEnd", ...)
SeriesAggreg.OutputsModel <- function(x, ...) {
res <- SeriesAggreg.list(x, except = "StateEnd", ...)
return(res)
}
\ No newline at end of file
}
R/SeriesAggreg.R
View file @ c27f77f5
SeriesAggreg <- function(TabSeries, Format, ...) {
SeriesAggreg <- function(x, Format, ...) {
UseMethod("SeriesAggreg")
}
R/SeriesAggreg.data.frame.R
View file @ c27f77f5
SeriesAggreg.data.frame <- function(TabSeries,
SeriesAggreg.data.frame <- function(x,
Format,
ConvertFun = getAggregConvertFun(names(TabSeries)[-1]),
ConvertFun = getAggregConvertFun(names(x)[-1]),
TimeFormat = NULL,
NewTimeFormat = NULL,
YearFirstMonth = 1,
......@@ -20,27 +20,27 @@ SeriesAggreg.data.frame <- function(TabSeries,
stop("argument 'Format' is missing")
}
## check TabSeries
if (!is.data.frame(TabSeries)) {
stop("'TabSeries' must be a data.frame containing the dates and data to be aggregated")
## check x
if (!is.data.frame(x)) {
stop("'x' must be a data.frame containing the dates and data to be aggregated")
}
if (ncol(TabSeries) < 2) {
stop("'TabSeries' must contain at least two columns (including the column of dates)")
if (ncol(x) < 2) {
stop("'x' must contain at least two columns (including the column of dates)")
}
## check TabSeries date column
if (!inherits(TabSeries[[1L]], "POSIXt")) {
stop("'TabSeries' first column must be a vector of class 'POSIXlt' or 'POSIXct'")
## check x date column
if (!inherits(x[[1L]], "POSIXt")) {
stop("'x' first column must be a vector of class 'POSIXlt' or 'POSIXct'")
}
if (inherits(TabSeries[[1L]], "POSIXlt")) {
TabSeries[[1L]] <- as.POSIXct(TabSeries[[1L]])
if (inherits(x[[1L]], "POSIXlt")) {
x[[1L]] <- as.POSIXct(x[[1L]])
}
## check TabSeries other columns (boolean converted to numeric)
## check x other columns (boolean converted to numeric)
apply(
TabSeries[, -1L, drop = FALSE],
x[, -1L, drop = FALSE],
MARGIN = 2,
FUN = function(iCol) {
if (!is.numeric(iCol)) {
stop("'TabSeries' columns (other than the first one) must be of numeric class")
stop("'x' columns (other than the first one) must be of numeric class")
}
}
)
......@@ -57,10 +57,10 @@ SeriesAggreg.data.frame <- function(TabSeries,
if (anyNA(ConvertFun)) {
stop("'ConvertFun' should be a one of 'sum' or 'mean'")
}
if (length(ConvertFun) != (ncol(TabSeries) - 1)) {
if (length(ConvertFun) != (ncol(x) - 1)) {
stop(sprintf(
"'ConvertFun' must be of length %i (ncol(TabSeries)-1)",
ncol(TabSeries) - 1
"'ConvertFun' must be of length %i (ncol(x)-1)",
ncol(x) - 1
))
}
## check YearFirstMonth
......@@ -89,8 +89,7 @@ SeriesAggreg.data.frame <- function(TabSeries,
stop(msgTimeLag)
}
TabSeries0 <- TabSeries
TabSeries0 <- x
colnames(TabSeries0)[1L] <- "DatesR"
TabSeries0$DatesR <- TabSeries0$DatesR + TimeLag
......@@ -105,7 +104,7 @@ SeriesAggreg.data.frame <- function(TabSeries,
1)
by <-
ifelse(grepl("hours", format(diff(
TabSeries$DatesR[1:2]
x$DatesR[1:2]
))), yes = "hours", no = "days")
fakeTs <-
data.frame(DatesR = seq(
......@@ -126,9 +125,9 @@ SeriesAggreg.data.frame <- function(TabSeries,
TabSeries2$Selec <- !duplicated(TabSeries2$Selec2)
if (all(TabSeries2$Selec)) {
warning(
"the requested time 'Format' is the same as the one in 'TabSeries'. No time-step conversion was performed"
"the requested time 'Format' is the same as the one in 'x'. No time-step conversion was performed"
)
return(TabSeries)
return(x)
}
if (Format == "%Y") {
yfm <- sprintf("%02.f", YearFirstMonth)
......@@ -148,16 +147,16 @@ SeriesAggreg.data.frame <- function(TabSeries,
}
TabSeries2$Fac2 <- TabSeries2$Selec2
TabSeries2$Selec <- !duplicated(TabSeries2$Selec2)
ConvertFun <- rep("mean", ncol(TabSeries) - 1)
ConvertFun <- rep("mean", ncol(x) - 1)
}
#browser()
listTsAggreg <- lapply(names(listConvertFun), function(x) {
if (any(ConvertFun == x)) {
listTsAggreg <- lapply(names(listConvertFun), function(y) {
if (any(ConvertFun == y)) {
colTsAggreg <-
c("Fac2", colnames(TabSeries)[-1L][ConvertFun == x])
c("Fac2", colnames(x)[-1L][ConvertFun == y])
aggregate(. ~ Fac2,
data = TabSeries2[, colTsAggreg],
FUN = listConvertFun[[x]],
FUN = listConvertFun[[y]],
na.action = na.pass)
} else {
NULL
......
R/SeriesAggreg.list.R
View file @ c27f77f5
SeriesAggreg.list <- function(TabSeries,
SeriesAggreg.list <- function(x,
Format,
ConvertFun,
NewTimeFormat = NULL,
......@@ -6,10 +6,6 @@ SeriesAggreg.list <- function(TabSeries,
except = NULL,
recursive = TRUE,
...) {
if (!is.list(TabSeries)) {
stop("to be used with a list")
}
if (missing(Format)) {
Format <- getSeriesAggregFormat(NewTimeFormat)
} else if (!is.null(NewTimeFormat)) {
......@@ -18,31 +14,31 @@ SeriesAggreg.list <- function(TabSeries,
}
# Determination of DatesR
if (!is.null(TabSeries$DatesR)) {
if (!inherits(TabSeries$DatesR, "POSIXt")) {
stop("'TabSeries$DatesR' should be of class 'POSIXt'")
if (!is.null(x$DatesR)) {
if (!inherits(x$DatesR, "POSIXt")) {
stop("'x$DatesR' should be of class 'POSIXt'")
}
DatesR <- TabSeries$DatesR
DatesR <- x$DatesR
} else {
# Auto-detection of POSIXt item in Tabseries
itemPOSIXt <-
which(sapply(TabSeries, function(x) {
which(sapply(x, function(x) {
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 'x' should be of class 'POSIXt'")
}
warning(
"Item 'DatesR' not found in 'TabSeries' argument: the item ",
names(TabSeries)[itemPOSIXt],
"Item 'DatesR' not found in 'x' argument: the item ",
names(x)[itemPOSIXt],
" has been automatically chosen"
)
DatesR <- TabSeries[[names(TabSeries)[itemPOSIXt]]]
DatesR <- x[[names(x)[itemPOSIXt]]]
}
# Selection of numeric items for aggregation
numericCols <- names(which(sapply(TabSeries, inherits, "numeric")))
arrayCols <- names(which(sapply(TabSeries, inherits, "array")))
numericCols <- names(which(sapply(x, inherits, "numeric")))
arrayCols <- names(which(sapply(x, inherits, "array")))
numericCols <- setdiff(numericCols, arrayCols)
if (!is.null(except)) {
if (!inherits(except, "character")) {
......@@ -51,14 +47,14 @@ SeriesAggreg.list <- function(TabSeries,
numericCols <- setdiff(numericCols, except)
}
cols <- TabSeries[numericCols]
cols <- x[numericCols]
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' ",
"The length of the following `numeric` items in 'x' ",
"is different than the length of 'DatesR (",
length(DatesR),
")': they will be ignored in the aggregation: ",
......@@ -97,10 +93,10 @@ SeriesAggreg.list <- function(TabSeries,
# 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 <- x[sapply(x, inherits, "list")]
dfCols <- x[sapply(x, inherits, "data.frame")]
dfCols <-
c(dfCols, TabSeries[sapply(TabSeries, inherits, "matrix")])
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
......@@ -153,13 +149,13 @@ SeriesAggreg.list <- function(TabSeries,
}
# Store elements that are not aggregated
res <- c(res, TabSeries[setdiff(names(TabSeries), names(res))])
res <- c(res, x[setdiff(names(x), names(res))])
class(res) <-
gsub(
"hourly|daily|monthly|yearly",
getSeriesAggregClass(Format),
class(TabSeries)
class(x)
)
return(res)
......
R/UtilsSeriesAggreg.R
View file @ c27f77f5
......@@ -47,7 +47,7 @@ getSeriesAggregClass <- function(Format) {
Outputs = c("Prod","Rout","Exp","SnowPack","ThermalState",
"Gratio","Temp","Gthreshold","Glocalmax","LayerTempMean", "T")),
data.frame(ConvertFun = "sum",
Outputs = c("zzz","PotEvap","Precip","Pn","Ps","AE","Perc","PR","Q9",
Outputs = c("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", "Qupstream"))
......
man/RunModel_GR1A.Rd
View file @ c27f77f5
......@@ -64,7 +64,7 @@ TabSeries <- TabSeries[TabSeries$DatesR < "2012-09-01",]
TimeFormat <- "\%Y"
YearFirstMonth <- 09
ConvertFun <- c("sum", "sum", "sum")
BasinObs <- SeriesAggreg(TabSeries = TabSeries, Format = TimeFormat,
BasinObs <- SeriesAggreg(TabSeries, Format = TimeFormat,
YearFirstMonth = YearFirstMonth, ConvertFun = ConvertFun)
## preparation of the InputsModel object
......
man/SeriesAggreg.Rd
View file @ c27f77f5
......@@ -31,16 +31,16 @@ Warning: on the aggregated outputs, the dates correspond to the beginning of the
\usage{
\method{SeriesAggreg}{data.frame}(TabSeries,
\method{SeriesAggreg}{data.frame}(x,
Format,
ConvertFun = getAggregConvertFun(names(TabSeries)[-1]),
ConvertFun = getAggregConvertFun(names(x)[-1]),
TimeFormat = NULL,
NewTimeFormat = NULL,
YearFirstMonth = 1,
TimeLag = 0,
\dots)
\method{SeriesAggreg}{list}(TabSeries,
\method{SeriesAggreg}{list}(x,
Format,
ConvertFun,
NewTimeFormat = NULL,
......@@ -49,20 +49,20 @@ Warning: on the aggregated outputs, the dates correspond to the beginning of the
recursive = TRUE,
\dots)
\method{SeriesAggreg}{InputsModel}(TabSeries, \dots)
\method{SeriesAggreg}{InputsModel}(x, \dots)
\method{SeriesAggreg}{OutputsModel}(TabSeries, \dots)
\method{SeriesAggreg}{OutputsModel}(x, \dots)
}
\arguments{
\item{TabSeries}{[InputsModel], [OutputsModel], [list] or [data.frame] containing the vector of dates (POSIXt) and the time series of numeric values}
\item{x}{[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"})}
\item{TimeFormat}{(deprecated) [character] input time step format (i.e. \code{"hourly"}, \code{"daily"}, \code{"monthly"} or \code{"yearly"})}
\item{NewTimeFormat}{(deprecated) [character] output time step format (i.e. \code{"hourly"}, \code{"daily"}, \code{"monthly"} or \code{"yearly"}). Use the \code{TabSeries} argument instead}
\item{NewTimeFormat}{(deprecated) [character] output time step format (i.e. \code{"hourly"}, \code{"daily"}, \code{"monthly"} or \code{"yearly"}). Use the \code{x} 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 "mean" for regime calculation)}
......@@ -95,13 +95,13 @@ data(L0123002)
TabSeries <- BasinObs[, c("DatesR", "P", "E", "T", "Qmm")]
## monthly time series
NewTabSeries <- SeriesAggreg(TabSeries = TabSeries,
NewTabSeries <- SeriesAggreg(TabSeries,
Format = "\%Y\%m",
ConvertFun = c("sum", "sum", "mean", "sum"))
str(NewTabSeries)
## monthly regimes
NewTabSeries <- SeriesAggreg(TabSeries = TabSeries,
NewTabSeries <- SeriesAggreg(TabSeries,
Format = "\%m",
ConvertFun = c("sum", "sum", "mean", "sum"))
str(NewTabSeries)
......
tests/testthat/test-SeriesAggreg.R
View file @ c27f77f5
......@@ -5,55 +5,51 @@ data(L0123002)
test_that("No warning with InputsModel Cemaneige'", {
## preparation of the InputsModel object
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_CemaNeige,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
TempMean = BasinObs$T,
ZInputs = BasinInfo$HypsoData[51],
HypsoData = BasinInfo$HypsoData,
NLayers = 5
)
InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_CemaNeige,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
TempMean = BasinObs$T,
ZInputs = BasinInfo$HypsoData[51],
HypsoData = BasinInfo$HypsoData,
NLayers = 5
)
# Expect no warning: https://stackoverflow.com/a/33638939/5300212
expect_warning(SeriesAggreg(InputsModel, "%m"),
regexp = NA)
})
test_that("Warning: deprecated 'TimeFormat' argument", {
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
expect_warning(SeriesAggreg(InputsModel, Format = "%Y%m", TimeFormat = "daily"),
regexp = "deprecated 'TimeFormat' argument")
})
test_that("Warning: deprecated 'NewTimeFormat' argument: please use 'Format' instead",
{
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
expect_warning(SeriesAggreg(InputsModel, NewTimeFormat = "monthly"),
regexp = "deprecated 'NewTimeFormat' argument: please use 'Format' instead")
})
test_that("Warning: deprecated 'NewTimeFormat' argument: 'Format' argument is used instead",
{
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
expect_warning(SeriesAggreg(InputsModel, Format = "%Y%m", NewTimeFormat = "monthly"),
regexp = "deprecated 'NewTimeFormat' argument: 'Format' argument is used instead")
})
......@@ -85,13 +81,12 @@ test_that("No DatesR should warning", {
})
test_that("Check SeriesAggreg.list 'DatesR' argument", {
InputsModel <-
CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J,
DatesR = BasinObs$DatesR,
Precip = BasinObs$P,
PotEvap = BasinObs$E
)
DatesR <- InputsModel$DatesR
# No InputsModel$DatesR
InputsModel$DatesR <- NULL
......@@ -186,7 +181,8 @@ test_that("Check data.frame handling in SeriesAggreg.list", {
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
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")
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