Commit 7e27e077 authored by Dorchies David's avatar Dorchies David
Browse files

feat(CreateInputsModel): Qobs is optional

- code, doc example and tests updated

Refs #60
parent 9c199919
......@@ -2,9 +2,9 @@
#'
#' @param x \[GRiwrm object\] diagram of the semi-distributed model (See [CreateGRiwrm])
#' @param DatesR [POSIXt] vector of dates
#' @param Precip [matrix] or [data.frame] frame of numeric containing precipitation in \[mm per time step\]. Column names correspond to node IDs
#' @param PotEvap [matrix] or [data.frame] frame of numeric containing potential evaporation \[mm per time step\]. Column names correspond to node IDs
#' @param Qobs [matrix] or [data.frame] frame of numeric containing observed flows in \[mm per time step\]. Column names correspond to node IDs
#' @param Precip (optional) [matrix] or [data.frame] frame of numeric containing precipitation in \[mm per time step\]. Column names correspond to node IDs
#' @param PotEvap (optional) [matrix] or [data.frame] frame of numeric containing potential evaporation \[mm per time step\]. Column names correspond to node IDs
#' @param Qobs (optional) [matrix] or [data.frame] frame of numeric containing observed flows in \[mm per time step\]. Column names correspond to node IDs
#' @param PrecipScale (optional) named [vector] of [logical] indicating if the mean of the precipitation interpolated on the elevation layers must be kept or not, required to create CemaNeige module inputs, default `TRUE` (the mean of the precipitation is kept to the original value)
#' @param TempMean (optional) [matrix] or [data.frame] of time series of mean air temperature \[°C\], required to create the CemaNeige module inputs
#' @param TempMin (optional) [matrix] or [data.frame] of time series of minimum air temperature \[°C\], possibly used to create the CemaNeige module inputs
......@@ -50,11 +50,9 @@
#' PotEvap <- matrix(BasinObs$E, ncol = 1)
#' colnames(PotEvap) <- "GaugingDown"
#'
#' # Observed flows are integrated now because we mix:
#' # - flows that are directly injected in the model
#' # - flows that could be used for the calibration of the hydrological models
#' Qobs = matrix(c(Qupstream, BasinObs$Qmm), ncol = 2)
#' colnames(Qobs) <- griwrm$id
#' # Observed flows should at least contains flows that are directly injected in the model
#' Qobs = matrix(Qupstream, ncol = 1)
#' colnames(Qobs) <- "Reservoir"
#' str(Qobs)
#'
#' InputsModels <- CreateInputsModel(griwrm,
......@@ -65,16 +63,16 @@
#' str(InputsModels)
#'
CreateInputsModel.GRiwrm <- function(x, DatesR,
Precip,
Precip = NULL,
PotEvap = NULL,
Qobs,
Qobs = NULL,
PrecipScale = TRUE,
TempMean = NULL, TempMin = NULL,
TempMax = NULL, ZInputs = NULL,
HypsoData = NULL, NLayers = 5, ...) {
# Check and format inputs
varNames <- c("Precip", "PotEvap", "TempMean",
varNames <- c("Precip", "PotEvap", "TempMean", "Qobs",
"TempMin", "TempMax", "ZInputs", "HypsoData", "NLayers")
names(varNames) <- varNames
lapply(varNames, function(varName) {
......@@ -98,8 +96,35 @@ CreateInputsModel.GRiwrm <- function(x, DatesR,
}
})
directFlowIds <- x$id[is.na(x$model)]
if (length(directFlowIds) > 0) {
err <- FALSE
if (is.null(Qobs)) {
err <- TRUE
} else {
Qobs <- as.matrix(Qobs)
if (is.null(colnames(Qobs))) {
err <- TRUE
} else if (!all(directFlowIds %in% colnames(Qobs))) {
err <- TRUE
}
}
if (err) stop(sprintf("'Qobs' column names must at least contain %s", paste(directFlowIds, collapse = ", ")))
}
InputsModel <- CreateEmptyGRiwrmInputsModel(x)
# Qobs completion
Qobs0 <- matrix(0, nrow = length(DatesR), ncol = nrow(x))
colnames(Qobs0) <- x$id
if (is.null(Qobs)) {
Qobs <- Qobs0
} else {
missingIDs <- which(!x$id %in% colnames(Qobs))
}
for(id in getNodeRanking(x)) {
message("CreateInputsModel.GRiwrm: Treating sub-basin ", id, "...")
InputsModel[[id]] <-
......@@ -141,9 +166,10 @@ CreateEmptyGRiwrmInputsModel <- function(griwrm) {
#'
#' @param id string of the node identifier
#' @param griwrm See [CreateGRiwrm])
#' @param DatesR vector of dates required to create the GR model and CemaNeige module inputs
#' @param Precip time series of potential evapotranspiration (catchment average) (mm/time step)
#' @param PotEvap time series of potential evapotranspiration (catchment average) (mm/time step)
#' @param ... parameters sent to [airGR::CreateInputsModel]:
#' - `DatesR` [vector] of dates required to create the GR model and CemaNeige module inputs
#' - `Precip` [vector] time series of potential evapotranspiration (catchment average) (mm/time step)
#' - `PotEvap` [vector] time series of potential evapotranspiration (catchment average) (mm/time step)
#' @param Qobs Matrix or data frame of numeric containing observed flow (mm/time step). Column names correspond to node IDs
#'
#' @return \emph{InputsModel} object for one.
......
......@@ -7,9 +7,9 @@
\method{CreateInputsModel}{GRiwrm}(
x,
DatesR,
Precip,
Precip = NULL,
PotEvap = NULL,
Qobs,
Qobs = NULL,
PrecipScale = TRUE,
TempMean = NULL,
TempMin = NULL,
......@@ -25,11 +25,11 @@
\item{DatesR}{\link{POSIXt} vector of dates}
\item{Precip}{\link{matrix} or \link{data.frame} frame of numeric containing precipitation in [mm per time step]. Column names correspond to node IDs}
\item{Precip}{(optional) \link{matrix} or \link{data.frame} frame of numeric containing precipitation in [mm per time step]. Column names correspond to node IDs}
\item{PotEvap}{\link{matrix} or \link{data.frame} frame of numeric containing potential evaporation [mm per time step]. Column names correspond to node IDs}
\item{PotEvap}{(optional) \link{matrix} or \link{data.frame} frame of numeric containing potential evaporation [mm per time step]. Column names correspond to node IDs}
\item{Qobs}{\link{matrix} or \link{data.frame} frame of numeric containing observed flows in [mm per time step]. Column names correspond to node IDs}
\item{Qobs}{(optional) \link{matrix} or \link{data.frame} frame of numeric containing observed flows in [mm per time step]. Column names correspond to node IDs}
\item{PrecipScale}{(optional) named \link{vector} of \link{logical} indicating if the mean of the precipitation interpolated on the elevation layers must be kept or not, required to create CemaNeige module inputs, default \code{TRUE} (the mean of the precipitation is kept to the original value)}
......@@ -88,11 +88,9 @@ colnames(Precip) <- "GaugingDown"
PotEvap <- matrix(BasinObs$E, ncol = 1)
colnames(PotEvap) <- "GaugingDown"
# Observed flows are integrated now because we mix:
# - flows that are directly injected in the model
# - flows that could be used for the calibration of the hydrological models
Qobs = matrix(c(Qupstream, BasinObs$Qmm), ncol = 2)
colnames(Qobs) <- griwrm$id
# Observed flows should at least contains flows that are directly injected in the model
Qobs = matrix(Qupstream, ncol = 1)
colnames(Qobs) <- "Reservoir"
str(Qobs)
InputsModels <- CreateInputsModel(griwrm,
......
......@@ -10,17 +10,16 @@ test_that("CemaNeige data should be in InputsModel", {
PotEvap = l$PotEvap,
TempMean = l$TempMean,
ZInputs = l$ZInputs,
HypsoData = l$HypsoData,
Qobs = l$Qobs)
HypsoData = l$HypsoData)
)
l$DatesR <- as.data.frame(l$DatesR)
lapply(InputsModels, function(IM) {
lapply(c("DatesR", "Precip", "PotEvap"), function(varName) {
expect_equal(IM[[varName]], l[[varName]][,1])
expect_equal(IM[[varName]], l[[varName]][, 1])
})
expect_named(IM$LayerPrecip, paste0("L", seq(1,5)))
expect_named(IM$LayerTempMean, paste0("L", seq(1,5)))
expect_named(IM$LayerFracSolidPrecip, paste0("L", seq(1,5)))
expect_named(IM$LayerPrecip, paste0("L", seq(1, 5)))
expect_named(IM$LayerTempMean, paste0("L", seq(1, 5)))
expect_named(IM$LayerFracSolidPrecip, paste0("L", seq(1, 5)))
})
})
......@@ -32,16 +31,16 @@ test_that("downstream sub-catchment area should be positive", {
PotEvap = l$PotEvap,
TempMean = l$TempMean,
ZInputs = l$ZInputs,
HypsoData = l$HypsoData,
Qobs = l$Qobs))
HypsoData = l$HypsoData),
regexp = "must be greater than the sum of the areas")
})
test_that("handles mix of with and without CemaNeige nodes", {
l$griwrm[l$griwrm$id == "Down", "model"] <- "RunModel_GR4J"
l$TempMean <- l$TempMean[,1:2]
l$TempMean <- l$TempMean[, 1:2]
l$ZInputs <- l$ZInputs[1:2]
l$TempMean <- l$TempMean[,1:2]
l$HypsoData <- l$HypsoData[,1:2]
l$TempMean <- l$TempMean[, 1:2]
l$HypsoData <- l$HypsoData[, 1:2]
InputsModels <- suppressWarnings(
CreateInputsModel(l$griwrm,
DatesR = l$DatesR,
......@@ -49,8 +48,7 @@ test_that("handles mix of with and without CemaNeige nodes", {
PotEvap = l$PotEvap,
TempMean = l$TempMean,
ZInputs = l$ZInputs,
HypsoData = l$HypsoData,
Qobs = l$Qobs)
HypsoData = l$HypsoData)
)
expect_false(inherits(InputsModels$Down, "CemaNeige"))
expect_null(InputsModels$Down$LayerPrecip)
......@@ -64,8 +62,8 @@ test_that("throws error on wrong column name", {
PotEvap = l$PotEvap,
TempMean = l$TempMean,
ZInputs = l$ZInputs,
HypsoData = l$HypsoData,
Qobs = l$Qobs))
HypsoData = l$HypsoData),
regexp = "column names must be included in")
colnames(l$Precip) <- NULL
expect_error(CreateInputsModel(l$griwrm,
DatesR = l$DatesR,
......@@ -73,14 +71,35 @@ test_that("throws error on wrong column name", {
PotEvap = l$PotEvap,
TempMean = l$TempMean,
ZInputs = l$ZInputs,
HypsoData = l$HypsoData,
Qobs = l$Qobs))
HypsoData = l$HypsoData),
regexp = "must have column names")
})
test_that("throws error when missing CemaNeige data", {
test_that("throw error on missing column in inputs", {
l$Precip <- l$Precip[, -1]
expect_error(CreateInputsModel(l$griwrm,
DatesR = l$DatesR,
Precip = l$Precip,
PotEvap = l$PotEvap,
Qobs = l$Qobs))
TempMean = l$TempMean,
ZInputs = l$ZInputs,
HypsoData = l$HypsoData),
regexp = "Precip is missing")
})
test_that("throws error when missing CemaNeige data", {
expect_error(CreateInputsModel(l$griwrm,
DatesR = l$DatesR,
Precip = l$Precip,
PotEvap = l$PotEvap),
regexp = "'TempMean' is missing")
})
test_that("throws error when missing Qobs on node not related to an hydrological model", {
l$griwrm$model[1] <- NA
expect_error(CreateInputsModel(l$griwrm,
DatesR = l$DatesR,
Precip = l$Precip,
PotEvap = l$PotEvap),
regexp = "'Qobs' column names must at least contain")
})
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