.Rbuildignore

@@ -11,3 +11,4 @@
 ^pkgdown
 ^docs
 ^vignettes/seinebasin$
+^man-roxygen$

.gitlab-ci.yml

@@ -5,7 +5,7 @@ stages:
 default:
   tags: [docker]
 
-image: rocker/verse:latest
+image: rocker/verse:devel
 
 cache:
   paths:
@@ -51,6 +51,8 @@ website:
       - tags
   script:
     - R -e 'install.packages("pkgdown")'
+    - sed -i 's/`function`/function/g' man/CreateRunOptions.Rd
+    - sed -i 's/`function`/function/g' man/CreateCalibOptions.Rd
     - R -e 'remotes::install_gitlab("in-wop/seinebasin", host = "gitlab.irstea.fr")'
     - R -e 'pkgdown::build_site()'
     - sudo apt-get update && sudo apt-get install -y sshpass rsync

DESCRIPTION

 Package: airGRiwrm
 Title: 'airGR' Integrated Water Resource Management
-Version: 0.5.0.9000
+Version: 0.5.0.9002
 Authors@R: c(
     person("David", "Dorchies", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-6595-7984"), email = "david.dorchies@inrae.fr"),
     person("Olivier", "Delaigue", role = c("ctb"), comment = c(ORCID = "0000-0002-7668-8468"), email = "airGR@inrae.fr"),
@@ -11,13 +11,12 @@ License: AGPL-3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.1
+RoxygenNote: 7.1.2
 Imports:
     dplyr,
     utils,
     grDevices,
-    graphics,
-    airGR (>= 1.6.10.9000)
+    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

NAMESPACE

@@ -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)
@@ -31,6 +35,9 @@ export(CreateInputsModel)
 export(CreateRunOptions)
 export(CreateSupervisor)
 export(RunModel)
+export(getNoSD_Ids)
+export(getSD_Ids)
+export(isNodeDownstream)
 import(airGR)
 importFrom(grDevices,rainbow)
 importFrom(graphics,matplot)

NEWS

+airGRiwrm v0.5.9002 (in development)
+==========
+
+Changes:
+
+* Simplify the use of airGR in airGRiwrm #63
+
+
+airGRiwrm v0.5.9001 (Expiration date: 2021-12-12)
+==========
+
+New features:
+
+* Regularisation: Add default value for parameter Celerity #58
+
+Changes:
+
+* [CreateInputsModel] Make `Qobs` parameter optional #60
+
+Bug fixes:
+
+* Breaking change in airGR in issue HYCAR-Hydro/airgr#137 #62
+* Review documentation for publication on CRAN #43
+
+
+airGRiwrm v0.5.9000 (Expiration date: 2021-10-26)
+==========
+
+New features:
+
+* Add network consistency checks in `GRiwrm` #36
+* Handle CemaNeige compatibility #52
+* Use S3 plot method for GRiwrmOutputsModel class objects #26
+* Handling correctly initial conditions #48
+* Calibration with parameter regularisation #54
+
+Changes:
+
+* airGR compatibility: change on LengthHydro unit #32
+* CreateInputsCrit: Change obs parameter characteristics #38
+* Update URLs in the DESCRIPTION file #45
+* Use S3 plot method for GRiwrm class objects #26
+* Rename function GRiwrm to CreateGRiwrm #46
+* CreateInputsCrit: transfo is mandatory for parameter regularisation #56
+
+Bug fixes:
+
+* Vignettes: working directory instability #35
+* airGR compatibility: debugged version of RunModel_Lag #33
+* CreateInputsModel: Error when using data.frame for Qobs #37
+* `RunModel.Supervisor`: Error in ctrlr$U[seq.int(length(sv$ts.index)), i] #39
+* Supervisor: measurement on network downstream node returns `NULL` #40
+* RunModel: Suspected bug on `OutputsModel$Qsim` in the training example #41
+* Test fail after airGR update on outputing warm-up Qsim #50
+* Wrong Qobs use in Lavenne function criteria #57
+
+
+Internal changes:
+
+* Push roxygen outputs on the repository #34
+* Generation of the https://airgriwrm.g-eau.net site documentation #44
+* Automatically update website from package repository #47
+
+
+airGRiwrm v0.5.0 (Release date: 2021-03-07)
+==========
+
+New features:
+
+* Feedback control #19
+* RunModel of GRiwrm networks: add a data.frame of simulated flows in OutputsModel #30
+* Plot simulated flows of all the nodes in m3/s #31
+
+Changes:
+
+* RunModel: Uncoupling of hydrological and hydraulic models #28
+
+
+airGRiwrm v0.4.0 (Release date: 2020-12-28)
+==========
+
+New features:
+
+* Convert basin meteorological data to sub-basin level #21
+
+Changes:
+
+* Clarify dependency with 'DiagrammeR' package #24
+
+Minor changes:
+
+* Replace vignette examples on Seine River by a fake example from data provided by airGR #13
+
+Bug fixes:
+
+* Impossibility to inject flow associated to an area #23
+* Error in the area used for the sub basins #22
+
+
+airGRiwrm v0.3.1 (Release date: 2020-08-07)
+==========
+
+New features:
+
+* Calibration of influenced semi-distributed model #11
+
+
+airGRiwrm v0.3.0 (Release date: 2020-08-07)
+==========
+
+New features:
+
+* Add node of type "direct flow" in order to inject or withdraw flows into the model #5
+
+
+airGRiwrm v0.2.1 (Release date: 2020-06-11)
+==========
+
+Changes:
+
+* Remove Gits class object and use CreateInputsModel directly #7
+* Remove Girop class object and integrate hydrological model and area in Ginet #9
+* Rename "Ginet" class object to "Griwrm" #10
+
+
+airGRiwrm v0.2.0 (Release date: 2020-06-06)
+==========
+
+New features:
+
+* Calibration of semi-distributed model #3
+
+
+airGRiwrm v0.1.0 (Release date: 2020-05-25)
+==========
+
+New features:
+
+* Database structuration #1
+* Scheduling airGR model runs #2

R/Calibration.GRiwrmInputsModel.R

@@ -8,24 +8,47 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
                                           useUpstreamQsim = TRUE,
                                           ...) {
 
+  # Argument checks
+
+  # We invoke the mandatory arguments here for avoiding
+  # a messy error message on "get(x)" if an argument is missing
+  InputsModel
+  RunOptions
+  InputsCrit
+  CalibOptions
+
+  # Checking argument classes
+  vars2check <- c("InputsModel", "RunOptions", "InputsCrit", "CalibOptions")
+  lapply(vars2check, function(x) {
+    if (!inherits(get(x), paste0("GRiwrm", x))) {
+      stop(sprintf("'%1$s' must be of class GRiwrm%1$s, type '?Create%1$s' for help", x))
+    }
+  })
+
   OutputsCalib <- list()
-  class(OutputsCalib) <- append(class(OutputsCalib), "GRiwrmOutputsCalib")
+  class(OutputsCalib) <- append("GRiwrmOutputsCalib", class(OutputsCalib))
 
   OutputsModel <- list()
-  class(OutputsModel) <- append(class(OutputsModel), "GRiwrmOutputsModel")
+  class(OutputsModel) <- append("GRiwrmOutputsModel", class(OutputsModel))
 
   for(IM in InputsModel) {
     message("Calibration.GRiwrmInputsModel: Treating sub-basin ", IM$id, "...")
 
     if(useUpstreamQsim && any(IM$UpstreamIsRunoff)) {
       # Update InputsModel$Qupstream with simulated upstream flows
-      IM <- UpdateQsimUpstream(IM, RunOptions[[IM$id]]$IndPeriod_Run, OutputsModel)
+      IM <- UpdateQsimUpstream(IM, RunOptions[[IM$id]], OutputsModel)
+    }
+
+    if (inherits(InputsCrit[[IM$id]], "InputsCritLavenneFunction")) {
+      IC <- getInputsCrit_Lavenne(IM$id, OutputsModel, InputsCrit)
+    } else {
+      IC <- InputsCrit[[IM$id]]
     }
 
     OutputsCalib[[IM$id]] <- Calibration(
       InputsModel = IM,
       RunOptions = RunOptions[[IM$id]],
-      InputsCrit = InputsCrit[[IM$id]],
+      InputsCrit = IC,
       CalibOptions = CalibOptions[[IM$id]],
       ...
     )
@@ -44,3 +67,32 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
   return(OutputsCalib)
 
 }
+
+#' Create InputsCrit for De Lavenne regularisation
+#'
+#' Internal function that run [airGR::CreateInputsCrit_Lavenne] on-the-fly with a priori upstream
+#' sub-catchment parameters grabbed during network calibration process.
+#'
+#' @param id [character] the id of the current sub-catchment
+#' @param OutputsModel \[GRiwrmOutputsModel\] object with simulation results of upstream sub-catchments run with calibrated parameters
+#' @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) {
+  if (!inherits(InputsCrit[[id]], "InputsCritLavenneFunction")) {
+    stop("'InputsCrit[[id]]' must be of class InputsCritLavenneFunction")
+  }
+  AprioriId <- attr(InputsCrit[[id]], "AprioriId")
+  AprCelerity <- attr(InputsCrit[[id]], "AprCelerity")
+  Lavenne_FUN <- attr(InputsCrit[[id]], "Lavenne_FUN")
+  AprParamR <- OutputsModel[[AprioriId]]$RunOptions$Param
+  if(!inherits(OutputsModel[[AprioriId]], "SD")) {
+    # Add default velocity parameter for a priori upstream catchment
+    AprParamR <- c(AprCelerity, AprParamR)
+  }
+  AprCrit <- ErrorCrit(InputsCrit[[AprioriId]], OutputsModel[[AprioriId]])$CritValue
+  return(Lavenne_FUN(AprParamR, AprCrit))
+}

R/Calibration.InputsModel.R

 #' @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, ...)
+  }
 }

R/Calibration.R

@@ -18,7 +18,7 @@
 #'
 #' @return Depending on the class of `InputsModel` argument (respectively `InputsModel` and `GRiwrmInputsModel` object), the returned value is respectively:
 #' - a `InputsCrit` object (See [airGR::CreateInputsCrit])
-#' - a `GRiwrmInputsCrit` object which is a [list] of `InputsCrit` object with one item per modelled sub-catchment
+#' - a `GRiwrmInputsCrit` object which is a [list] of `InputsCrit` objects with one item per modelled sub-catchment
 #'
 #' @rdname Calibration
 #' @export

R/CreateCalibOptions.GRiwrmInputsModel.R

 #' @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,
       ...
     )
   }

R/CreateCalibOptions.InputsModel.R

-#' @rdname CreateCalibOptions
-#' @export
-CreateCalibOptions.InputsModel <- function(InputsModel,
-                               ...) {
-  airGR::CreateCalibOptions(
-    FUN_MOD = InputsModel$FUN_MOD,
-    IsSD = !is.null(InputsModel$Qupstream),
-    ...
-  )
-}

R/CreateCalibOptions.R

@@ -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,
+    ...
+  )
 }

R/CreateGRiwrm.R

@@ -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(

R/CreateInputsCrit.GRiwrmInputsModel.R

 #' @rdname CreateInputsCrit
+#' @import airGR
 #' @export
 CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
-                                               FUN_CRIT = airGR::ErrorCrit_NSE,
+                                               FUN_CRIT = ErrorCrit_NSE,
                                                RunOptions,
                                                Obs,
+                                               AprioriIds = NULL,
+                                               k = 0.15,
+                                               AprCelerity = 1,
                                                ...) {
+  # Parameter checks
+
+  # We invoke the mandatory arguments here for avoiding
+  # a messy error message on "get(x)" if an argument is missing
+  # We also list all arguments in order to check arguments even in "..."
+  arguments <- c(as.list(environment()), list(...))
+
+  # Checking argument classes
+  lVars2Check <- list(InputsModel = "GRiwrmInputsModel",
+                      RunOptions = "GRiwrmRunOptions",
+                      Obs = c("matrix", "data.frame"))
+  lapply(names(lVars2Check), function(argName) {
+    b <- sapply(lVars2Check[[argName]], function(argClass) {
+      !inherits(get(argName), argClass)
+    })
+    if (all(b)) {
+      stop(sprintf("'%s' must be of class %s", argName, paste(lVars2Check[[argName]], collapse = " or ")))
+    }
+  })
+
+  if (!is.null(AprioriIds)) {
+    AprioriIds <- unlist(AprioriIds)
+    if (!is.character(AprioriIds) || is.null(names(AprioriIds))) {
+      stop("Argument 'AprioriIds' must be a named list or a named vector of characters")
+    }
+    if (length(unique(names(AprioriIds))) != length(names(AprioriIds))) {
+      stop("Each name of AprioriIds items must be unique: duplicate entry detected")
+    }
+    if ("Weights" %in% names(arguments)) {
+      stop("Argument 'Weights' cannot be used when using Lavenne criterion")
+    }
+    if (!"transfo" %in% names(arguments)) {
+      stop("Argument 'transfo' must be defined when using Lavenne criterion (Using \"sqrt\" is recommended)")
+    }
+    lapply(names(AprioriIds), function(id) {
+      if (!id %in% names(InputsModel)) {
+        stop("'Each item of names(AprioriIds) must be an id of a simulated node:",
+             " the id \"", id ,"\" is unknown")
+      }
+      if (!AprioriIds[id] %in% names(InputsModel)) {
+        stop("'Each item of AprioriIds must be an id of a simulated node:",
+             " the id \"", id ,"\" is unknown")
+      }
+      if (! isNodeDownstream(InputsModel, AprioriIds[id], id)) {
+        stop("'AprioriIds': the node \"", AprioriIds[id],
+             "\" is not upstream the node \"", id,"\"")
+      }
+    })
+  }
+
   InputsCrit <- list()
-  class(InputsCrit) <- append(class(InputsCrit), "GRiwrmInputsCrit")
+  class(InputsCrit) <- append("GRiwrmInputsCrit", class(InputsCrit))
 
   for(IM in InputsModel) {
     InputsCrit[[IM$id]] <- CreateInputsCrit.InputsModel(
@@ -16,7 +70,49 @@ CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
       Obs = Obs[, IM$id],
       ...
     )
+    if (!is.null(AprioriIds) && IM$id %in% names(AprioriIds)) {
+      # De Lavenne regularisation for this sub-catchment
+      attr(InputsCrit[[IM$id]], "Lavenne_FUN") <-
+        CreateLavenneFunction(
+          InputsModel = IM,
+          FUN_CRIT = FUN_CRIT,
+          RunOptions = RunOptions[[IM$id]],
+          Obs = Obs[, IM$id],
+          k = k,
+          ...
+        )
+      attr(InputsCrit[[IM$id]], "AprioriId") <- AprioriIds[IM$id]
+      attr(InputsCrit[[IM$id]], "AprCelerity") <- AprCelerity
+      class(InputsCrit[[IM$id]]) <- c("InputsCritLavenneFunction", class(InputsCrit[[IM$id]]))
+    }
   }
 
   return(InputsCrit)
 }
+
+#' Generate a `CreateInputsCrit_Lavenne` function which embeds know parameters
+#'
+#' The created function will be used in calibration for injecting necessary `AprParamR` and `AprCrit`
+#' parameters, which can be known only during calibration process, in the call of `CreateInputsCrit_Lavenne`.
+#'
+#' @param InputsModel See [CreateInputsCrit] parameters
+#' @param FUN_CRIT See [CreateInputsCrit] parameters
+#' @param RunOptions See [CreateInputsCrit] parameters
+#' @param Obs See [CreateInputsCrit] parameters
+#' @param k See [CreateInputsCrit] parameters
+#' @param ... further arguments for [airGR::CreateInputsCrit_Lavenne]
+#'
+#' @return A function with `AprParamR` and `AprCrit`
+#' @noRd
+#'
+CreateLavenneFunction <- function(InputsModel, FUN_CRIT, RunOptions, Obs, k, ...) {
+  # The following line solve the issue #57 by forcing the evaluation of all the parameters.
+  # See also: https://stackoverflow.com/questions/69016698/is-there-a-bug-on-closures-embedded-in-a-list-in-r/69028161#69028161
+  arguments <- c(as.list(environment()), list(...))
+  function(AprParamR, AprCrit) {
+    do.call(
+      CreateInputsCrit_Lavenne,
+      c(arguments, list(AprParamR = AprParamR, AprCrit = AprCrit))
+    )
+  }
+}

R/CreateInputsCrit.R

@@ -6,17 +6,26 @@
 #' @param FUN_CRIT \[function (atomic or list)\] error criterion function (e.g. [airGR::ErrorCrit_RMSE], [airGR::ErrorCrit_NSE])
 #' @param RunOptions object of class \emph{RunOptions} or \emph{GRiwrmRunOptions}, see [CreateRunOptions]
 #' @param Obs [numeric], [matrix] or [data.frame] series of observed flows, see details
+#' @param AprioriIds (optional) named [list] or named [vector] of [character] used for the parameter regularisation (see details)
+#' @param k (optional) [numeric] weight coefficient used in the parameter regularisation (See [airGR::CreateInputsCrit_Lavenne])
+#' @param AprCelerity (optional) [numeric] Default celerity used as a priori parameter for upstream catchments
 #' @param ... arguments passed to [airGR::CreateInputsCrit], see details
 #'
 #' @details See [airGR::CreateInputsCrit] documentation for a complete list of arguments.
 #'
-#' `Obs` argument is equivalent to the same argument in [airGR::CreateInputsCrit] except that it must a [matrix] or a [data.frame] if `InputsModel` is a \emph{GRiwrmInputsModel} object. Then, each column of the [matrix] or [data.frame] represents the observations of one of the simulated node with the name of the columns representing the id of each node.
+#' `Obs` argument is equivalent to the same argument in [airGR::CreateInputsCrit] except that it must be a [matrix] or a [data.frame] if `InputsModel` is a \emph{GRiwrmInputsModel} object.
+#' Then, each column of the [matrix] or [data.frame] represents the observations of one of the simulated node with the name of the columns representing the id of each node.
 #'
 #' With a \emph{GRiwrmInputsModel} object, all arguments are applied on each sub-catchments of the network.
 #'
+#' Parameter regularisation consists of defining a priori parameters which are used in a composed criterion based on the formula proposed by Lavenne et al. (2019) (See [airGR::CreateInputsCrit_Lavenne]).
+#' The parameter `AprioriIds` allows to define which upstream sub-catchment is used for providing a priori parameters. Its format is as follows: `AprioriIds <- c("Downstream sub-catchment 1" = "A priori upstream sub-catchment 1", ...)` where the quoted strings are the ids of the sub-catchments. See vignettes for more details. The parameter `AprCelerity` is a default value used as a priori for the parameter 'Celerity' in case of an upstream catchment (without celerity parameter) is used as a priori catchment.
+#'
 #' @return Depending on the class of `InputsModel` argument (respectively `InputsModel` and `GRiwrmInputsModel` object), the returned value is respectively:
 #' - a `InputsCrit` object (See [airGR::CreateInputsCrit])
-#' - a `GRiwrmInputsCrit` object which is a [list] of `InputsCrit` object with one item per modelled sub-catchment
+#' - a `GRiwrmInputsCrit` object which is a [list] of `InputsCrit` objects with one item per modelled sub-catchment
+#'
+#' @references De Lavenne, A., Andréassian, V., Thirel, G., Ramos, M.-H., Perrin, C., 2019. A Regularization Approach to Improve the Sequential Calibration of a Semidistributed Hydrological Model. Water Resources Research 55, 8821–8839. \doi{10.1029/2018WR024266}
 #'
 #' @rdname CreateInputsCrit
 #' @export

R/CreateInputsModel.GRiwrm.R

@@ -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
@@ -20,86 +20,75 @@
 #'
 #' @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 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)
-#'
-#' 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,
+                                     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) {
     v <- get(varName)
-    if(!is.null(v)) {
-      if(is.matrix(v) || is.data.frame(v)) {
-        if(is.null(colnames(v))) {
+    if (!is.null(v)) {
+      if (is.matrix(v) || is.data.frame(v)) {
+        if (is.null(colnames(v))) {
           stop(sprintf(
             "'%s' must have column names",
             varName
           ))
-        } else if(!all(colnames(v) %in% x$id)) {
+        } else if (!all(colnames(v) %in% x$id)) {
           stop(sprintf(
             "'%s' column names must be included in 'id's of the GRiwrm object",
             varName
           ))
         }
+        if (!varName %in% c("ZInputs", "NLayers", "HypsoData") && nrow(v) != length(DatesR)) {
+          stop("'%s' number of rows and the length of 'DatesR' must be equal",
+               varName)
+        }
+
       } else if (!varName %in% c("ZInputs", "NLayers")) {
         stop(sprintf("'%s' must be a matrix or a data.frame", varName))
       }
     }
   })
 
+  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[is.na(Qobs)] <- -99 # airGR::CreateInputsModel doesn't accept NA values
+
+  # Qobs completion
+  Qobs0 <- matrix(0, nrow = length(DatesR), ncol = nrow(x))
+  colnames(Qobs0) <- x$id
+  if (is.null(Qobs)) {
+    Qobs <- Qobs0
+  } else {
+    Qobs0[, colnames(Qobs)] <- Qobs
+    Qobs <- Qobs0
+  }
 
   for(id in getNodeRanking(x)) {
     message("CreateInputsModel.GRiwrm: Treating sub-basin ", id, "...")
@@ -142,9 +131,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.

R/CreateInputsModel.R

 #' Generic function for creating `InputsModel` object for either **airGR** or **airGRiwrm**
 #'
-#' See the methods [CreateInputsModel.GRiwrm] for **airGRiwrm** and [CreateInputsModel.default] for **airGR**.
+#' See the methods [CreateInputsModel.GRiwrm] for **airGRiwrm** and [airGR::CreateInputsModel] for **airGR**.
 #'
 #' @param x First parameter determining which InputsModel object is created
 #' @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, ...)
+}

R/CreateInputsModel.default.R

-#' 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, ...)
-}

R/CreateRunOptions.GRiwrmInputsModel.R

+#' @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, ...) {
+CreateRunOptions.GRiwrmInputsModel <- function(x, IniStates = NULL, ...) {
 
   RunOptions <- list()
   class(RunOptions) <- append(class(RunOptions), "GRiwrmRunOptions")
 
-  for(InputsModelBasin in InputsModel) {
-    RunOptions[[InputsModelBasin$id]] <- CreateRunOptions(InputsModel = InputsModelBasin, ...)
+  for(id in names(x)) {
+    RunOptions[[id]] <- CreateRunOptions(x[[id]], IniStates = IniStates[[id]], ...)
   }
   return(RunOptions)
 }

R/CreateRunOptions.InputsModel.R

-#' @rdname CreateRunOptions
-#' @export
-CreateRunOptions.InputsModel <- function(InputsModel, ...) {
-
-  airGR::CreateRunOptions(FUN_MOD = InputsModel$FUN_MOD,
-                          InputsModel = InputsModel,
-                          ...)
-}

R/CreateRunOptions.R

-#' Creation of the CalibOptions object
+#' Creation of the RunOptions object
 #'
 #' 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.
 #'
+#' If `InputsModel` argument is a \emph{GRiwrmInputsModel} object, `IniStates` must be a list of [numeric] object of class \emph{IniStates} with one item per modelled sub-catchment.
+#'
 #' With a \emph{GRiwrmInputsModel} object, all arguments are applied on each sub-catchments of the network.
 #'
-#' @return Depending on the class of `InputsModel` argument (respectively `InputsModel` and `GRiwrmInputsModel` object), the returned value is respectively:
+#' @return Depending on the class of `InputsModel` argument (respectively \emph{InputsModel} and \emph{GRiwrmInputsModel} object), the returned value is respectively:
 #' - a `RunOptions` object (See [airGR::CreateRunOptions])
-#' - a `GRiwrmRunOptions` object which is a [list] of `RunOptions` object with one item per modelled sub-catchment
+#' - a `GRiwrmRunOptions` object which is a [list] of `RunOptions` objects with one item per modelled sub-catchment
 #'
 #' @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,
+                          ...)
 }