Commit 7564a7c6 authored by Dorchies David's avatar Dorchies David
Browse files

Merge branch '63-simplify-the-use-of-airgr-in-airgriwrm' into 'dev'

Resolve "Simplify the use of airGR in airGRiwrm"

Closes #63

See merge request !30
parents 017769e9 d5943d28
Pipeline #30004 passed with stages
in 18 minutes and 41 seconds
......@@ -11,3 +11,4 @@
^pkgdown
^docs
^vignettes/seinebasin$
^man-roxygen$
......@@ -16,8 +16,7 @@ Imports:
dplyr,
utils,
grDevices,
graphics,
airGR (>= 1.6.12.9001)
graphics
Suggests:
knitr,
rmarkdown,
......@@ -29,6 +28,7 @@ VignetteBuilder: knitr
URL: https://airgriwrm.g-eau.fr/
BugReports: https://gitlab.irstea.fr/in-wop/airGRiwrm/-/issues/
Depends:
R (>= 2.10)
R (>= 2.10),
airGR (>= 1.6.12.9001)
Remotes:
url::https://gitlab.irstea.fr/HYCAR-Hydro/airgr/-/archive/dev/airgr-dev.zip
......@@ -5,14 +5,18 @@ S3method(Calibration,InputsModel)
S3method(ConvertMeteoSD,GRiwrm)
S3method(ConvertMeteoSD,character)
S3method(ConvertMeteoSD,matrix)
S3method(CreateCalibOptions,"function")
S3method(CreateCalibOptions,GRiwrmInputsModel)
S3method(CreateCalibOptions,InputsModel)
S3method(CreateCalibOptions,character)
S3method(CreateInputsCrit,GRiwrmInputsModel)
S3method(CreateInputsCrit,InputsModel)
S3method(CreateInputsModel,GRiwrm)
S3method(CreateInputsModel,default)
S3method(CreateRunOptions,"function")
S3method(CreateRunOptions,GRiwrmInputsModel)
S3method(CreateRunOptions,InputsModel)
S3method(CreateRunOptions,character)
S3method(RunModel,GR)
S3method(RunModel,GRiwrmInputsModel)
S3method(RunModel,InputsModel)
......
......@@ -78,6 +78,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
#' @param InputsCrit \[InputsCritLavenneFunction\] object internally created by [CreateInputsCrit.GRiwrmInputsModel]
#'
#' @return \[InputsCrit\] object with De Lavenne regularisation
#' @import airGR
#' @noRd
#'
getInputsCrit_Lavenne <- function(id, OutputsModel, InputsCrit) {
......
#' @rdname Calibration
#' @export
Calibration.InputsModel <- function(InputsModel, ...) {
airGR::Calibration(InputsModel, FUN_MOD = InputsModel$FUN_MOD, ...)
if (!exists("FUN_MOD") && !is.null(InputsModel$FUN_MOD)) {
airGR::Calibration(InputsModel, FUN_MOD = InputsModel$FUN_MOD, ...)
} else {
airGR::Calibration(InputsModel, ...)
}
}
#' @rdname CreateCalibOptions
#' @export
CreateCalibOptions.GRiwrmInputsModel <- function(InputsModel, ...) {
CreateCalibOptions.GRiwrmInputsModel <- function(x, ...) {
CalibOptions <- list()
class(CalibOptions) <- c("GRiwrmCalibOptions", class(CalibOptions))
for(IM in InputsModel) {
CalibOptions[[IM$id]] <- CreateCalibOptions.InputsModel(
InputsModel = IM,
for(IM in x) {
CalibOptions[[IM$id]] <- CreateCalibOptions(
IM,
...
)
}
......
#' @rdname CreateCalibOptions
#' @export
CreateCalibOptions.InputsModel <- function(InputsModel,
...) {
airGR::CreateCalibOptions(
FUN_MOD = InputsModel$FUN_MOD,
IsSD = !is.null(InputsModel$Qupstream),
...
)
}
......@@ -2,7 +2,7 @@
#'
#' This function can be used either for a catchment (with an \emph{InputsModel} object) or for a network (with a \emph{GRiwrmInputsModel} object)
#'
#' @param InputsModel object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}. See [CreateInputsModel] for details
#' @template param_x
#' @param ... arguments passed to [airGR::CreateCalibOptions], see details
#'
#' @details See [airGR::CreateCalibOptions] documentation for a complete list of arguments.
......@@ -15,6 +15,43 @@
#'
#' @rdname CreateCalibOptions
#' @export
CreateCalibOptions <- function(InputsModel, ...) {
UseMethod("CreateCalibOptions", InputsModel)
CreateCalibOptions <- function(x, ...) {
UseMethod("CreateCalibOptions", x)
}
#' @rdname CreateCalibOptions
#' @export
CreateCalibOptions.InputsModel <- function(x,
...) {
if (!exists("FUN_MOD") && !is.null(x$FUN_MOD)) {
airGR::CreateCalibOptions(
FUN_MOD = x$FUN_MOD,
IsSD = !is.null(x$Qupstream),
...
)
} else {
airGR::CreateCalibOptions(
...
)
}
}
#' @rdname CreateCalibOptions
#' @export
CreateCalibOptions.character <- function(x,
...) {
airGR::CreateCalibOptions(
FUN_MOD = x,
...
)
}
#' @rdname CreateCalibOptions
#' @export
CreateCalibOptions.function <- function(x,
...) {
airGR::CreateCalibOptions(
FUN_MOD = x,
...
)
}
......@@ -21,28 +21,7 @@
#'
#' @aliases GRiwrm
#' @export
#' @examples
#' ###################################################################
#' # Run the `airGR::RunModel_Lag` example in the GRiwrm fashion way #
#' ###################################################################
#'
#' # Run the airGR RunModel_Lag example for harvesting the necessary data
#' library(airGR)
#' example(RunModel_Lag)
#' # detach the package because otherwise airGR overwrites the airGRiwrm functions
#' detach("package:airGR")
#'
#' # This example is a network of 2 nodes which can be described like this:
#' db <- data.frame(id = c("Reservoir", "GaugingDown"),
#' length = c(LengthHydro, NA),
#' down = c("GaugingDown", NA),
#' area = c(NA, BasinInfo$BasinArea),
#' model = c(NA, "RunModel_GR4J"),
#' stringsAsFactors = FALSE)
#'
#' # Create GRiwrm object from the data.frame
#' griwrm <- CreateGRiwrm(db)
#' str(griwrm)
#' @inherit RunModel.GRiwrmInputsModel return examples
#'
CreateGRiwrm <- function(db,
cols = list(
......
#' @rdname CreateInputsCrit
#' @import airGR
#' @export
CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
FUN_CRIT = airGR::ErrorCrit_NSE,
FUN_CRIT = ErrorCrit_NSE,
RunOptions,
Obs,
AprioriIds = NULL,
......
......@@ -20,47 +20,7 @@
#'
#' @return A \emph{GRiwrmInputsModel} object which is a list of \emph{InputsModel} objects created by [airGR::CreateInputsModel] with one item per modelled sub-catchment.
#' @export
#' @examples
#' ##################################################################
#' # Run the `airGR RunModel_Lag` example in the GRiwrm fashion way #
#' ##################################################################
#'
#' # Run the airGR RunModel_Lag example for harvesting necessary data
#' library(airGR)
#' example(RunModel_Lag)
#' # detach the package because otherwise airGR overwrites the airGRiwrm functions
#' detach("package:airGR")
#'
#' # This example is a network of 2 nodes which can be described like this:
#' db <- data.frame(id = c("Reservoir", "GaugingDown"),
#' length = c(LengthHydro, NA),
#' down = c("GaugingDown", NA),
#' area = c(NA, BasinInfo$BasinArea),
#' model = c(NA, "RunModel_GR4J"),
#' stringsAsFactors = FALSE)
#'
#' # Create GRiwrm object from the data.frame
#' griwrm <- CreateGRiwrm(db)
#' str(griwrm)
#'
#' # Formatting observations for the hydrological models
#' # Each input data should be a matrix or a data.frame with the correct id as the column name
#' Precip <- matrix(BasinObs$P, ncol = 1)
#' colnames(Precip) <- "GaugingDown"
#' PotEvap <- matrix(BasinObs$E, ncol = 1)
#' colnames(PotEvap) <- "GaugingDown"
#'
#' # 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,
#' DatesR = BasinObs$DatesR,
#' Precip = Precip,
#' PotEvap = PotEvap,
#' Qobs = Qobs)
#' str(InputsModels)
#' @inherit RunModel.GRiwrmInputsModel return examples
#'
CreateInputsModel.GRiwrm <- function(x, DatesR,
Precip = NULL,
......
......@@ -6,7 +6,17 @@
#' @param ... further arguments passed to or from other methods.
#'
#' @return InputsModel or GRiwrmInputsObject object
#' @rdname CreateInputsModel
#' @import airGR
#' @export
CreateInputsModel <- function(x, ...) {
UseMethod("CreateInputsModel", x)
}
#' @rdname CreateInputsModel
#' @export
CreateInputsModel.default <- function(x,
...) {
airGR::CreateInputsModel(FUN_MOD = x, ...)
}
#' Wrapper for [airGR::CreateInputsModel] for one sub-basin
#'
#' @param x [function] hydrological model function (e.g. [airGR::RunModel_GR4J]...)
#' @param ... arguments passed to [airGR::CreateInputsModel]
#' @import airGR
#' @export
#'
CreateInputsModel.default <- function(x,
...) {
airGR::CreateInputsModel(FUN_MOD = x, ...)
}
#' @param IniStates (optional) [numeric] object or [list] of [numeric] object of class \emph{IniStates}, see [airGR::CreateIniStates] for details
#' @rdname CreateRunOptions
#' @export
CreateRunOptions.GRiwrmInputsModel <- function(InputsModel, IniStates = NULL, ...) {
CreateRunOptions.GRiwrmInputsModel <- function(x, IniStates = NULL, ...) {
RunOptions <- list()
class(RunOptions) <- append(class(RunOptions), "GRiwrmRunOptions")
for(id in names(InputsModel)) {
RunOptions[[id]] <- CreateRunOptions(InputsModel = InputsModel[[id]], IniStates = IniStates[[id]], ...)
for(id in names(x)) {
RunOptions[[id]] <- CreateRunOptions(x[[id]], IniStates = IniStates[[id]], ...)
}
return(RunOptions)
}
#' @rdname CreateRunOptions
#' @export
CreateRunOptions.InputsModel <- function(InputsModel, ...) {
airGR::CreateRunOptions(FUN_MOD = InputsModel$FUN_MOD,
InputsModel = InputsModel,
...)
}
......@@ -2,7 +2,7 @@
#'
#' This function can be used either for a catchment (with an \emph{InputsModel} object) or for a network (with a \emph{GRiwrmInputsModel} object)
#'
#' @param InputsModel object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}. See [CreateInputsModel] for details
#' @template param_x
#' @param ... arguments passed to [airGR::CreateRunOptions], see details
#'
#' @details See [airGR::CreateRunOptions] documentation for a complete list of arguments.
......@@ -18,6 +18,35 @@
#' @rdname CreateRunOptions
#' @export
#' @inherit RunModel.GRiwrmInputsModel return examples
CreateRunOptions <- function(InputsModel, ...) {
UseMethod("CreateRunOptions", InputsModel)
CreateRunOptions <- function(x, ...) {
UseMethod("CreateRunOptions", x)
}
#' @rdname CreateRunOptions
#' @export
CreateRunOptions.InputsModel <- function(x, ...) {
if (!exists("FUN_MOD") && !is.null(x$FUN_MOD)) {
airGR::CreateRunOptions(FUN_MOD = x$FUN_MOD,
InputsModel = x,
...)
} else {
airGR::CreateRunOptions(InputsModel = x,
...)
}
}
#' @rdname CreateRunOptions
#' @export
CreateRunOptions.character <- function(x, ...) {
airGR::CreateRunOptions(FUN_MOD = x,
...)
}
#' @rdname CreateRunOptions
#' @export
CreateRunOptions.function <- function(x, ...) {
airGR::CreateRunOptions(FUN_MOD = x,
...)
}
......@@ -14,7 +14,6 @@
#' @examples
#' data(Severn)
#' nodes <- Severn$BasinsInfo[, c("gauge_id", "downstream_id", "distance_downstream", "area")]
#' nodes$distance_downstream <- nodes$distance_downstream * 1000 # Conversion km -> m
#' nodes$model <- "RunModel_GR4J"
#' griwrm <- CreateGRiwrm(nodes,
#' list(id = "gauge_id",
......
#' Run of a rainfall-runoff model on a sub-basin
#'
#' @inherit airGR::RunModel
#' @param x \[object of class `InputsModel`\] `InputsModel` for [airGR::RunModel]
#' @param RunOptions \[object of class *RunOptions*\] see [airGR::CreateRunOptions] for details
#' @param Param [numeric] vector of model parameters (See details for SD lag model)
#' @param ... further arguments passed to or from other methods
#'
#' @inherit airGR::RunModel description details return
#' @export
#'
RunModel.GR <- function(x, RunOptions, Param, ...) {
......
......@@ -8,15 +8,36 @@
#' @return [[list] of class \emph{GRiwrmOutputsModel}] list of \emph{OutputsModel} objects (See \[airGR::RunModel]) for each node of the semi-distributed model
#' @export
#' @examples
#' #################################################################
#' # Run the `airGRRunModel_Lag` example in the GRiwrm fashion way #
#' #################################################################
#' ###################################################################
#' # Run the `airGR::RunModel_Lag` example in the GRiwrm fashion way #
#' # Simulation of a reservoir with a purpose of low-flow mitigation #
#' ###################################################################
#'
#' # Run the airGR RunModel_Lag example for harvesting necessary data
#' library(airGR)
#' example(RunModel_Lag)
#' # detach the package because otherwise airGR overwrites the airGRiwrm functions
#' detach("package:airGR")
#' ## ---- preparation of the InputsModel object
#'
#' ## loading package and catchment data
#' library(airGRiwrm)
#' data(L0123001)
#'
#' ## ---- specifications of the reservoir
#'
#' ## the reservoir withdraws 1 m3/s when it's possible considering the flow observed in the basin
#' Qupstream <- matrix(-sapply(BasinObs$Qls / 1000 - 1, function(x) {
#' min(1, max(0, x, na.rm = TRUE))
#' }), ncol = 1)
#'
#' ## except between July and September when the reservoir releases 3 m3/s for low-flow mitigation
#' month <- as.numeric(format(BasinObs$DatesR, "%m"))
#' Qupstream[month >= 7 & month <= 9] <- 3
#' Qupstream <- Qupstream * 86400 ## Conversion in m3/day
#'
#' ## the reservoir is not an upstream subcachment: its areas is NA
#' BasinAreas <- c(NA, BasinInfo$BasinArea)
#'
#' ## delay time between the reservoir and the catchment outlet is 2 days and the distance is 150 km
#' LengthHydro <- 150
#' ## with a delay of 2 days for 150 km, the flow velocity is 75 km per day
#' Velocity <- (LengthHydro * 1e3 / 2) / (24 * 60 * 60) ## Conversion km/day -> m/s
#'
#' # This example is a network of 2 nodes which can be describe like this:
#' db <- data.frame(id = c("Reservoir", "GaugingDown"),
......@@ -37,12 +58,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
#' str(Qobs)
#' # Observed flows contain flows that are directly injected in the model
#' Qobs = matrix(Qupstream, ncol = 1)
#' colnames(Qobs) <- "Reservoir"
#'
#' # Creation of the GRiwrmInputsModel object (= a named list of InputsModel objects)
#' InputsModels <- CreateInputsModel(griwrm,
......@@ -52,22 +70,27 @@
#' Qobs = Qobs)
#' str(InputsModels)
#'
#' ## run period selection
#' Ind_Run <- seq(which(format(BasinObs$DatesR, format = "%Y-%m-%d")=="1990-01-01"),
#' which(format(BasinObs$DatesR, format = "%Y-%m-%d")=="1999-12-31"))
#'
#' # Creation of the GriwmRunOptions object
#' RunOptions2 <- CreateRunOptions(InputsModels,
#' RunOptions <- CreateRunOptions(InputsModels,
#' IndPeriod_Run = Ind_Run)
#' str(RunOptions2)
#' str(RunOptions)
#'
#' # Parameters of the SD models should be encapsulated in a named list
#' Param2 <- list(`GaugingDown` = c(Velocity, Param))
#' ParamGR4J <- c(X1 = 257.238, X2 = 1.012, X3 = 88.235, X4 = 2.208)
#' Param <- list(`GaugingDown` = c(Velocity, ParamGR4J))
#'
#' # RunModel for the whole network
#' OutputsModels <- RunModel(InputsModels,
#' RunOptions = RunOptions2,
#' Param = Param2)
#' RunOptions = RunOptions,
#' Param = Param)
#' str(OutputsModels)
#'
#' # Comparison between GRiwrm simulation and airGR simulation
#' plot(OutputsModels, Qobs = data.frame(`GaugingDown` = OutputsModel$Qsim))
#' # Compare Simulation with reservoir and observation of natural flow
#' plot(OutputsModels, data.frame(GaugingDown = BasinObs$Qmm[Ind_Run]))
RunModel.GRiwrmInputsModel <- function(x, RunOptions, Param, ...) {
checkRunModelParameters(x, RunOptions, Param)
......
#' @param x [function], [character], or object of class \emph{InputsModel} runs [airGR::CreateRunOptions]for a catchment. Use object of class \emph{GRiwrmInputsModel} for a network. See [CreateInputsModel] for details
#'
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