feat(Supervision): Implementation of supervision (not functional yet)

- Add functions for reading and writing data from and to the model
- Add doSupervision which process the regulation for one (or more ?) time steps
- Add method RunModel for Supervisor (change first argument of RunModel to `x`
- Improve documentation

Refs #19

R/Calibration.GRiwrmInputsModel.R

@@ -30,7 +30,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
       IM <- UpdateQsimUpstream(IM, RunOptions[[IM$id]]$IndPeriod_Run, OutputsModel)
     }
 
-    OutputsCalib[[IM$id]] <- Calibration.InputsModel(
+    OutputsCalib[[IM$id]] <- Calibration(
       InputsModel = IM,
       RunOptions = RunOptions[[IM$id]],
       InputsCrit = InputsCrit[[IM$id]],
@@ -41,7 +41,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
     if(useUpstreamQsim) {
       # Run the model for the sub-basin
       OutputsModel[[IM$id]] <- RunModel(
-        InputsModel = IM,
+        x = IM,
         RunOptions = RunOptions[[IM$id]],
         Param = OutputsCalib[[IM$id]]$ParamFinalR
       )

R/CreateInputsCrit.GRiwrmInputsModel.R

 #' Create \emph{GRiwrmInputsCrit} object for **airGRiwrm**.
+#'
+#' This function does the same operations as [airGR::CreateInputsCrit] for all sub-basins of the GRiwrm model.
+#'
 #' @param InputsModel  object of class \emph{GRiwrmInputsModel}, see \code{\link{CreateInputsModel.GRiwrm}} for details.
 #' @param FUN_CRIT \[function (atomic or list)\] error criterion function (e.g. \code{\link[airGR]{ErrorCrit_RMSE}}, \code{\link[airGR]{ErrorCrit_NSE}})
 #' @param RunOptions object of class \emph{GRiwrmRunOptions}, see \code{[CreateRunOptions.GRiwrm]} for details.
 #' @param Qobs matrix or data frame containing observed flows. Column names correspond to nodes ID
-#' @param ... further arguments passed to \code{\link[airGR]{CreateInputsCrit}}.
+#' @param ... further arguments passed to [airGR::CreateInputsCrit].
 #'
-#' @return Object of class \emph{GRiwrmInputsCrit}
+#' @return Object of class \emph{GRiwrmInputsCrit} which is a list of `airGR::InputsCrit` objects (See [airGR::CreateInputsCrit])
 #' @export
 CreateInputsCrit.GRiwrmInputsModel <- function(InputsModel,
                                                FUN_CRIT = airGR::ErrorCrit_NSE,

R/CreateInputsModel.GRiwrm.R

@@ -26,10 +26,12 @@ CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, ...) {
 
 #' Create an empty InputsModel object for **airGRiwrm** nodes
 #'
+#' @param griwrm [GRiwrm] object
+#'
 #' @return \emph{GRiwrmInputsModel} empty object
 CreateEmptyGRiwrmInputsModel <- function() {
   InputsModel <- list()
-  class(InputsModel) <- append(class(InputsModel), "GRiwrmInputsModel")
+  class(InputsModel) <- c("GRiwrmInputsModel", class(InputsModel))
   return(InputsModel)
 }
 
@@ -79,6 +81,7 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, Precip, PotEvap, Qobs
 
   # Add Identifiers of connected nodes in order to be able to update them with simulated flows
   InputsModel$id <- id
+  InputsModel$down <- node$down
   if(length(UpstreamNodes) > 0) {
     InputsModel$UpstreamNodes <- UpstreamNodes
     InputsModel$UpstreamIsRunoff <- !is.na(griwrm$model[match(UpstreamNodes, griwrm$id)])

R/CreateInputsModel.R

-#' Create InputsModel object for either **airGR** or **airGRiwrm**
+#' Generic function for creating `InputsModel` object for either **airGR** or **airGRiwrm**
+#'
+#' See the methods [CreateInputsModel.GRiwrm] for **airGRiwrm** and [CreateInputsModel.default] for **airGR**.
 #'
 #' @param x First parameter determining which InputsModel object is created
 #' @param ... further arguments passed to or from other methods.

R/CreateSupervisor.R

-CreateSupervisor <- function(griwrm) {
+#' Create a Supervisor for handling regulation in a model
+#'
+#' @param InputsModel `GRiwrmInputsModel` The inputs of the basin model
+#'
+#' @return
+#' @export
+#'
+#' @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 <- GRiwrm(nodes, list(id = "gauge_id", down = "downstream_id", length = "distance_downstream"))
+#' BasinsObs <- Severn$BasinsObs
+#' DatesR <- BasinsObs[[1]]$DatesR
+#' PrecipTot <- cbind(sapply(BasinsObs, function(x) {x$precipitation}))
+#' PotEvapTot <- cbind(sapply(BasinsObs, function(x) {x$peti}))
+#' Qobs <- cbind(sapply(BasinsObs, function(x) {x$discharge_spec}))
+#' Precip <- ConvertMeteoSD(griwrm, PrecipTot)
+#' PotEvap <- ConvertMeteoSD(griwrm, PotEvapTot)
+#' InputsModel <- CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs)
+#' sv <- CreateSupervisor(InputsModel)
+CreateSupervisor <- function(InputsModel) {
   # Create Supervisor environment in the parent of GlobalEnv
   e <- new.env(parent = parent.env(globalenv()))
+  class(e) <- c("Supervisor", class(e))
 
   # Hidden variable to detect which environment it is
   e$.isSupervisor <- "3FJKmDcJ4snDbVBg"
@@ -8,14 +31,31 @@ CreateSupervisor <- function(griwrm) {
   # Add pointer to itself in order to assign variable from function environment
   e$supervisor <- e
 
-  e$griwrm <- griwrm
+  # Copy of the InputsModel
+  e$InputsModel <- InputsModel
+  e$OutputsModel <- list()
 
   # Controller list
-  e$Controllers <- list()
-  class(e$Controllers) <- c("Controllers", class(e$Controllers))
+  e$controllers <- list()
+  class(e$controllers) <- c("Controllers", class(e$controllers))
 
-  # Copy functions
+  # Copy functions to be used enclosed in the Supervisor environment
   e$createController <- createController
   environment(e$createController) <- e
+  e$getDataFromLocation <- getDataFromLocation
+  environment(getDataFromLocation) <- e
+  e$setDataToLocation <- setDataToLocation
+  environment(setDataToLocation) <- e
+  e$doSupervision <- doSupervision
+  environment(doSupervision) <- e
+
+  # Time steps handling: these data are provided by RunModel
+  # Index of the current time steps in the modelled time series between 1 and length(RunOptions$Ind_Period)
+  e$ts.index <- NA
+  # Index of the time step preceding RunOptions$Ind_Period
+  e$ts.index0 <- NA
+  # Date/Time of the current time step (For controller calculations based on date)
+  e$ts.date <- NULL
+
   return(e)
 }

R/RunModel.GR.R

 #' Run rainfall-runoff part of a sub-basin model
 #'
 #' @inherit airGR::RunModel
+#' @param x `InputsModel` used as `InputsModel` parameter for [airGR::RunModel]
 #' @param ... further arguments passed to or from other methods
 #'
 #' @export
 #'
-RunModel.GR <- function(InputsModel, RunOptions, Param, ...) {
+RunModel.GR <- function(x, RunOptions, Param, ...) {
+  message("RunModel.GR")
 
-  if (inherits(InputsModel, "SD")) {
+  if (inherits(x, "SD")) {
     # Lag model take one parameter at the beginning of the vector
     iFirstParamRunOffModel <- 2
   } else {
@@ -15,7 +17,7 @@ RunModel.GR <- function(InputsModel, RunOptions, Param, ...) {
     iFirstParamRunOffModel <- 1
   }
 
-  FUN_MOD <- match.fun(InputsModel$FUN_MOD)
-  FUN_MOD(InputsModel = InputsModel, RunOptions = RunOptions,
+  FUN_MOD <- match.fun(x$FUN_MOD)
+  FUN_MOD(x, RunOptions = RunOptions,
           Param = Param[iFirstParamRunOffModel:length(Param)])
 }

R/RunModel.GRiwrmInputsModel.R

 #' RunModel function for GRiwrmInputsModel object
 #'
-#' @param InputsModel object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details.
+#' @param x object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details.
 #' @param RunOptions object of class \emph{GRiwrmRunOptions}, see \code{[CreateRunOptions.GRiwrm]} for details.
 #' @param Param list of parameter. The list item names are the IDs of the sub-basins. Each item is a vector of numerical parameters.
 #' @param ... Mandatory for S3 method signature function compatibility with generic.
 #'
 #' @return \emph{GRiwrmOutputsModel} object which is a list of \emph{OutputsModel} objects (See \code{\link[airGR]{RunModel}}) for each node of the semi-distributed model.
 #' @export
-RunModel.GRiwrmInputsModel <- function(InputsModel, RunOptions, Param, ...) {
+RunModel.GRiwrmInputsModel <- function(x, RunOptions, Param, ...) {
+  message("RunModel.GRiwrmInputsModel")
 
   # Run runoff model for each sub-basin
-  OutputsModel <- lapply(X = InputsModel, FUN = function(IM) {
-    RunModel.GR(InputsModel = IM,
+  OutputsModel <- lapply(X = x, FUN = function(IM) {
+    RunModel.GR(IM,
                 RunOptions = RunOptions[[IM$id]],
                 Param = Param[[IM$id]])
     })
   class(OutputsModel) <- append(class(OutputsModel), "GRiwrmOutputsModel")
 
   # Loop over sub-basin using SD model
-  for(id in getSD_Ids(InputsModel)) {
-    IM <- InputsModel[[id]]
+  for(id in getSD_Ids(x)) {
+    IM <- x[[id]]
     message("RunModel.GRiwrmInputsModel: Treating sub-basin ", id, "...")
 
-    # Update InputsModel$Qupstream with simulated upstream flows
+    # Update x$Qupstream with simulated upstream flows
     if(any(IM$UpstreamIsRunoff)) {
       IM <- UpdateQsimUpstream(IM, RunOptions[[id]]$IndPeriod_Run, OutputsModel)
     }
 
     # Run the SD model for the sub-basin
     OutputsModel[[id]] <- RunModel.SD(
-      InputsModel = IM,
+      IM,
       RunOptions = RunOptions[[id]],
       Param = Param[[id]],
       OutputsModel[[id]]

R/RunModel.InputsModel.R

 #' Wrapper for \code{\link[airGR]{RunModel}} for one sub-basin.
 #'
 #' @inherit airGR::RunModel
+#' @param x `InputsModel` used as `InputsModel` parameter for [airGR::RunModel]
 #' @param ... Further arguments for compatibility with S3 method
 #' @export
-RunModel.InputsModel <- function(InputsModel, RunOptions, Param, FUN_MOD = NULL, ...) {
+RunModel.InputsModel <- function(x, RunOptions, Param, FUN_MOD = NULL, ...) {
   if(is.null(FUN_MOD)) {
-    FUN_MOD <- InputsModel$FUN_MOD
+    FUN_MOD <- x$FUN_MOD
   }
-  airGR::RunModel(InputsModel, RunOptions, Param, FUN_MOD)
+  airGR::RunModel(x, RunOptions, Param, FUN_MOD)
 }

R/RunModel.R

 #' RunModel function for both **airGR** InputsModel and GRiwrmInputsModel object
 #'
-#' @param InputsModel object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}. See \code{\link{CreateInputsModel}} for details
+#' @param x object of class \emph{InputsModel} or \emph{GRiwrmInputsModel}. See \code{\link{CreateInputsModel}} for details
 #' @param ... further arguments passed to or from other methods
 #'
 #' @return Either a [list] of OutputsModel object (for GRiwrmInputsModel) or an OutputsModel object (for InputsModel)
 #' @export
-RunModel <- function(InputsModel, ...) {
-  UseMethod("RunModel", InputsModel)
+RunModel <- function(x, ...) {
+  message("RunModel")
+  UseMethod("RunModel", x)
 }

R/RunModel.SD.R

 #' Run SD Model from run-off model outputs
 #'
 #' @inheritParams airGR::RunModel_Lag
+#' @param x `InputsModel` used as `InputsModel` parameter for [airGR::RunModel]
 #' @param OutputsModel `OutputsModel` object returned by a GR model by [airGR::RunModel]
 #' @param ... further arguments passed to or from other methods
 #'
 #' @return `OutputsModel` object. See [airGR::RunModel_Lag]
 #' @export
 #'
-RunModel.SD <- function(InputsModel, RunOptions, Param, OutputsModel, ...) {
-  InputsModel$OutputsModel <- OutputsModel
-  RunModel_Lag(InputsModel, RunOptions, Param[1])
+RunModel.SD <- function(x, RunOptions, Param, OutputsModel, ...) {
+  message("RunModel.SD")
+  x$OutputsModel <- OutputsModel
+  RunModel_Lag(x, RunOptions = RunOptions, Param = Param[1])
 }

R/RunModel.Supervisor.R

+#' RunModel function for GRiwrmInputsModel object
+#'
+#' @param InputsModel object of class \emph{GRiwrmInputsModel}, see \code{[CreateInputsModel.GRiwrm]} for details.
+#' @param RunOptions object of class \emph{GRiwrmRunOptions}, see \code{[CreateRunOptions.GRiwrm]} for details.
+#' @param Param list of parameter. The list item names are the IDs of the sub-basins. Each item is a vector of numerical parameters.
+#' @param ... Mandatory for S3 method signature function compatibility with generic.
+#'
+#' @return \emph{GRiwrmOutputsModel} object which is a list of \emph{OutputsModel} objects (See \code{\link[airGR]{RunModel}}) for each node of the semi-distributed model.
+#' @export
+RunModel.Supervisor <- function(x, RunOptions, Param, ...) {
+
+  x$ts.index0 <- sapply(RunOptions, function(x) {
+    x$IndPeriod_Run[1] - 1
+  })
+
+  # Run runoff model for each sub-basin
+  OutputsModel <- lapply(X = x$InputsModel, FUN = function(IM) {
+    RunModel.GR(IM,
+                RunOptions = RunOptions[[IM$id]],
+                Param = Param[[IM$id]])
+    })
+  class(OutputsModel) <- append(class(OutputsModel), "GRiwrmOutputsModel")
+
+  # Loop over time steps
+  # Loop over sub-basin using SD model
+  for(id in getSD_Ids(x$InputsModel)) {
+    IM <- x$InputsModel[[id]]
+    message("RunModel.GRiwrmInputsModel: Treating sub-basin ", id, "...")
+
+    # Update InputsModel$Qupstream with simulated upstream flows
+    if(any(IM$UpstreamIsRunoff)) {
+      IM <- UpdateQsimUpstream(IM, RunOptions[[id]]$IndPeriod_Run, OutputsModel)
+    }
+
+    # Run the SD model for the sub-basin
+    OutputsModel[[id]] <- RunModel.SD(
+      IM,
+      RunOptions = RunOptions[[id]],
+      Param = Param[[id]],
+      OutputsModel[[id]]
+    )
+
+  }
+  return(OutputsModel)
+}

R/createController.R

@@ -39,10 +39,10 @@ createController <- function(ctrl.id, Y, U, FUN){
   if(exists(".isSupervisor") && .isSupervisor == "3FJKmDcJ4snDbVBg") {
     # Function called from Supervisor environment
     environment(ctrlr$FUN) <- supervisor
-    if(!is.null(supervisor$Controllers[[ctrl.id]])) {
+    if(!is.null(supervisor$controllers[[ctrl.id]])) {
       warning("Controller '", ctrl.id, "' already exists in the supervisor: overwriting")
     }
-    supervisor$Controllers[[ctrl.id]] <- ctrlr
+    supervisor$controllers[[ctrl.id]] <- ctrlr
     message("The controller has been added to the supervisor")
     invisible(ctrlr)
   } else {

R/utils.R

@@ -13,3 +13,50 @@ getSD_Ids <- function(InputsModel) {
   })
   names(InputsModel)[bSDs]
 }
+
+
+#' Retrieve data in the model for the current time steps
+#'
+#' This function should be call inside a Supervisor
+#'
+#' @param loc location of the data
+#'
+#' @return [numeric] retrieved data at the location
+getDataFromLocation <- function(loc) {
+  if(grep("\\[[0-9]+\\]$", loc)) {
+    stop("Reaching output of other controller is not implemented yet")
+  } else {
+    supervisor$OutputsModel[[loc]]$Qsim[supervisor$ts.index - 1]
+  }
+}
+
+
+#' Write data to model input for the current time step
+#'
+#' @param control [list] A row of the `U` [data.frame] from a `Controller`
+#'
+#' @return [NULL]
+setDataToLocation <- function(control) {
+  node <- InputsModel[[control$loc]]$down
+  # ! Qupstream contains warm up period and run period => the index is shifted
+  supervisor$InputsModel[[node]]$Qupstream[ts.index0[node] + ts.index, control$loc] <- control$v
+}
+
+
+#' Do the supervision for the current time step
+#'
+#' @param supervisor `Supervisor` (See [CreateSupervisor])
+#'
+#' @return [NULL]
+doSupervision <- function(controllers) {
+  for(id in names(controllers)) {
+    ctrlr <- controllers[[id]]
+    # Read Y from locations in the model
+    supervisor$controllers[[id]]$Y$v <- sapply(controllers[[id]]$Y$loc, getDataFromLocation)
+    # Run logic
+    supervisor$controllers[[id]]$U$v <- sapply(controllers[[id]]$Y$v, controllers[[id]]$FUN)
+    # Write U to locations in the model
+    sapply(controllers[[id]]$U, setDataToLocation)
+  }
+  return()
+}

vignettes/V02_Calibration_SD_model.Rmd

@@ -128,7 +128,7 @@ ParamMichel <- sapply(griwrm$id, function(x) {OutputsCalib[[x]]$Param})
 
 ```{r RunModel}
 OutputsModels <- RunModel(
-  InputsModel = InputsModel,
+  InputsModel,
   RunOptions = RunOptions,
   Param = ParamMichel
 )

vignettes/V03_Open-loop_influenced_flow.Rmd

@@ -89,7 +89,7 @@ Param_OL <- sapply(griwrm$id, function(x) {OC_OL[[x]]$Param})
 
 ```{r RunModel}
 OM_OL <- RunModel(
-  InputsModel = IM_OL,
+  IM_OL,
   RunOptions = RunOptions,
   Param = Param_OL
 )