Merge branch '19-feature-request-feedback-control' into 'dev'

Resolve "Feature request: feedback control"

Closes #28, #30, #31, and #19

See merge request !11

.Rbuildignore

-^griwrm\.Rproj$
+^airGRiwrm\.Rproj$
 ^\.Rproj\.user$
 ^LICENSE\.md$
 ^\.gitlab-ci\.yml$

DESCRIPTION

 Package: airGRiwrm
-Title: airGR Integrated Water Resource Management
-Version: 0.4.0
+Title: 'airGR' Integrated Water Resource Management
+Version: 0.5.0
 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"),
     person("Guillaume", "Thirel", role = c("ctb"), comment = c(ORCID = "0000-0002-1444-1830"))
     )
-Description: This R package aims to model water basin using 'airGR' based semi-distributive model with the integration of human infrastructures and their management.
+Description: Semi-distributive Precipitation-Runoff Modelling based on 'airGR' package models integrating human infrastructures and their managements.
 License: AGPL-3
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.0
+RoxygenNote: 7.1.1
 Imports:
     dplyr,
     utils,
-    airGR (>= 1.6.1.11)
+    airGR (>= 1.6.1.11),
+    grDevices,
+    graphics
 Suggests:
     knitr,
     rmarkdown,

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

@@ -11,8 +11,8 @@
 #' @export
 CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, ...) {
 
-  InputsModel <- CreateEmptyGRiwrmInputsModel()
-  Qobs[is.na(Qobs)] <- -99 # airGRCreateInputsModel doesn't accept NA values
+  InputsModel <- CreateEmptyGRiwrmInputsModel(x)
+  Qobs[is.na(Qobs)] <- -99 # airGR::CreateInputsModel doesn't accept NA values
 
   for(id in getNodeRanking(x)) {
     message("CreateInputsModel.GRiwrm: Treating sub-basin ", id, "...")
@@ -20,16 +20,20 @@ CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, ...) {
       id, x, DatesR,Precip[,id], PotEvap[,id], Qobs, ...
     )
   }
+  attr(InputsModel, "TimeStep") <- getModelTimeStep(InputsModel)
   return(InputsModel)
 }
 
 
 #' Create an empty InputsModel object for **airGRiwrm** nodes
 #'
+#' @param griwrm a `GRiwrm` object (See [GRiwrm])
+#'
 #' @return \emph{GRiwrmInputsModel} empty object
-CreateEmptyGRiwrmInputsModel <- function() {
+CreateEmptyGRiwrmInputsModel <- function(griwrm) {
   InputsModel <- list()
-  class(InputsModel) <- append(class(InputsModel), "GRiwrmInputsModel")
+  class(InputsModel) <- c("GRiwrmInputsModel", class(InputsModel))
+  attr(InputsModel, "GRiwrm") <- griwrm
   return(InputsModel)
 }
 
@@ -79,6 +83,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)])
@@ -88,3 +93,28 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, Precip, PotEvap, Qobs
 
   return(InputsModel)
 }
+
+
+#' Check time steps of the model of all the nodes and return the time step in seconds
+#'
+#' This function is called inside [CreateInputsModel.GRiwrm] for defining the time step of the big model.
+#'
+#' @param InputsModel a `GRiwrmInputsModel`
+#'
+#' @return A [numeric] representing the time step in seconds
+#'
+getModelTimeStep <- function(InputsModel) {
+  TS <- sapply(InputsModel, function(x) {
+    if (inherits(x, "hourly")) {
+      TimeStep <- 60 * 60
+    } else if (inherits(x, "daily")) {
+      TimeStep <- 60 * 60 * 24
+    } else {
+      stop("All models should be at hourly or daily time step")
+    }
+  })
+  if(length(unique(TS)) != 1) {
+    stop("Time steps of the model of all nodes should be identical")
+  }
+  return(unique(TS))
+}

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

+#' Create a Supervisor for handling regulation in a model
+#'
+#' @param InputsModel `GRiwrmInputsModel` The inputs of the basin model
+#' @param TimeStep [integer] The number of time steps between each supervision
+#'
+#' @return `Supervisor` object
+#' @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, TimeStep = 1L) {
+  if(!inherits(InputsModel, "GRiwrmInputsModel")) {
+    stop("`InputsModel` parameter must of class 'GRiwrmInputsModel' (See ?CreateInputsModel.GRiwrm)")
+  }
+  if(!is.integer(TimeStep)) stop("`TimeStep` parameter must be an integer")
+
+  # Create Supervisor environment from 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"
+
+  # Add pointer to itself in order to assign variable from function environment
+  e$supervisor <- e
+
+  # Copy of InputsModel, griwrm and prepare OutputsModel
+  e$InputsModel <- InputsModel
+  e$griwrm <- attr(InputsModel, "GRiwrm")
+  e$OutputsModel <- list()
+  e$.TimeStep <- TimeStep
+
+  # Controller list
+  e$controllers <- list()
+  class(e$controllers) <- c("Controllers", class(e$controllers))
+
+  # Copy functions to be used enclosed in the Supervisor environment
+  e$CreateController <- CreateController
+  environment(e$CreateController) <- 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 previous time steps in the modelled time series
+  e$ts.previous <- 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
+
+  # Current Controller ID (Updated in doSupervision)
+  e$controller.id <- NULL
+
+  return(e)
+}

R/DiagramGRiwrm.R

@@ -23,7 +23,7 @@ DiagramGRiwrm <- function(griwrm, display = TRUE, orientation = "LR") {
   if(Sys.getenv("RSTUDIO") != "1") {
     return()
   }
-  if(!"DiagrammeR" %in% rownames(installed.packages())) {
+  if(!"DiagrammeR" %in% rownames(utils::installed.packages())) {
     stop("The 'DiagrammeR' package should be installed. Type: install.packages('DiagrammeR')")
   }
   g2 <- griwrm[!is.na(griwrm$down),]

R/GRiwrm.R

@@ -42,7 +42,6 @@ GRiwrm <- function(db,
                         length = "double",
                         model = "character",
                         area = "double"))
-  rownames(db) <- db$id
   class(db) <- c("GRiwrm", class(db))
   db
 }

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(x, RunOptions, Param, ...) {
+
+  if (inherits(x, "SD")) {
+    # Lag model take one parameter at the beginning of the vector
+    iFirstParamRunOffModel <- 2
+  } else {
+    # All parameters
+    iFirstParamRunOffModel <- 1
+  }
+
+  FUN_MOD <- match.fun(x$FUN_MOD)
+  FUN_MOD(x, RunOptions = RunOptions,
+          Param = Param[iFirstParamRunOffModel:length(Param)])
+}

R/RunModel.GRiwrmInputsModel.R

-#' Title
+#' 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, ...) {
+
+  checkRunModelParameters(x, RunOptions, Param)
 
   OutputsModel <- list()
-  class(OutputsModel) <- append(class(OutputsModel), "GRiwrmOutputsModel")
+  class(OutputsModel) <- c("GRiwrmOutputsModel", class(OutputsModel))
 
-  for(IM in InputsModel) {
-    message("RunModel.GRiwrmInputsModel: Treating sub-basin ", IM$id, "...")
+  for(id in names(x)) {
+    message("RunModel.GRiwrmInputsModel: Treating sub-basin ", x[[id]]$id, "...")
 
-    # Update InputsModel$Qupstream with simulated upstream flows
-    if(any(IM$UpstreamIsRunoff)) {
-      IM <- UpdateQsimUpstream(IM, RunOptions[[IM$id]]$IndPeriod_Run, OutputsModel)
+    # Update x[[id]]$Qupstream with simulated upstream flows
+    if(any(x[[id]]$UpstreamIsRunoff)) {
+      x[[id]] <- UpdateQsimUpstream(x[[id]], RunOptions[[id]]$IndPeriod_Run, OutputsModel)
     }
 
     # Run the model for the sub-basin
-    OutputsModel[[IM$id]] <- RunModel(
-      InputsModel = IM,
-      RunOptions = RunOptions[[IM$id]],
-      Param = Param[[IM$id]]
+    OutputsModel[[id]] <- RunModel.InputsModel(
+      x[[id]],
+      RunOptions = RunOptions[[id]],
+      Param = Param[[id]]
     )
-
   }
+  attr(OutputsModel, "Qm3s") <- OutputsModelQsim(x, OutputsModel, RunOptions[[1]]$IndPeriod_Run)
   return(OutputsModel)
 }

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, ...) {
+  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_Lag]
+#' @param QsimDown a [numeric] corresponding to the runoff of the sub-basin (Typically the `Qsim` outputs of the GR model)
+#' @param ... further arguments passed to or from other methods
+#'
+#' @return `OutputsModel` object. See [airGR::RunModel_Lag]
+#' @export
+#'
+RunModel.SD <- function(x, RunOptions, Param, QsimDown, ...) {
+  x$OutputsModel <- list(Qsim = QsimDown)
+  RunModel_Lag(x, RunOptions = RunOptions, Param = Param[1])
+}

R/RunModel.Supervisor.R

+#' RunModel function for GRiwrmInputsModel object
+#'
+#' @param x object of class `Supervisor`, see [CreateSupervisor] 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, ...) {
+
+  # Time steps handling
+  x$ts.index0 <- RunOptions[[1]]$IndPeriod_Run[1] - 1
+  ts.start <- RunOptions[[1]]$IndPeriod_Run[1]
+  ts.end <- RunOptions[[1]]$IndPeriod_Run[length(RunOptions[[1]]$IndPeriod_Run)]
+  superTSstarts <- seq(ts.start, ts.end, x$.TimeStep)
+  lSuperTS <- lapply(
+    superTSstarts, function(x, TS, xMax) {
+      seq(x, min(x + TS - 1, xMax))
+    },
+    TS = x$.TimeStep,
+    xMax = ts.end
+  )
+
+  # Run runoff model for each sub-basin
+  x$OutputsModel <- lapply(X = x$InputsModel, FUN = function(IM) {
+    RunModel.GR(IM,
+                RunOptions = RunOptions[[IM$id]],
+                Param = Param[[IM$id]])
+    })
+  class(x$OutputsModel) <- append(class(x$OutputsModel), "GRiwrmOutputsModel")
+  # Copy simulated pure runoff flows (no SD nodes) to Qupstream in downstream SD nodes
+  for(id in getNoSD_Ids(x$InputsModel)) {
+    downId <- x$InputsModel[[id]]$down
+    x$InputsModel[[downId]]$Qupstream[RunOptions[[downId]]$IndPeriod_Run, id] <-
+      x$OutputsModel[[id]]$Qsim
+  }
+
+  # Save Qsim for step by step simulation
+  Qsim <- lapply(x$OutputsModel, function(OM) {
+    OM$Qsim
+  })
+
+  # Adapt RunOptions to step by step simulation
+  for(id in getSD_Ids(x$InputsModel)) {
+    RunOptions[[id]]$IndPeriod_WarmUp <- 0L
+    RunOptions[[id]]$Outputs_Sim <- "StateEnd"
+  }
+
+  # Loop over time steps with a step equal to the supervision time step
+  for(iTS in lSuperTS) {
+    # Run regulation on the whole basin for the current time step
+    x$ts.index <- iTS - x$ts.index0
+    x$ts.date <- x$InputsModel[[1]]$DatesR[iTS]
+    # Regulation occurs from second time step
+    if(iTS[1] > ts.start) {
+      doSupervision(x)
+    }
+
+    # Loop over sub-basin using SD model
+    for(id in getSD_Ids(x$InputsModel)) {
+      # Run the SD model for the sub-basin and one time step
+      RunOptions[[id]]$IndPeriod_Run <- iTS
+      RunOptions[[id]]$IniStates <- unlist(x$OutputsModel[[id]]$StateEnd)
+      x$OutputsModel[[id]] <- RunModel.SD(
+        x$InputsModel[[id]],
+        RunOptions = RunOptions[[id]],
+        Param = Param[[id]],
+        QsimDown = Qsim[[id]][x$ts.index]
+      )
+      # Storing Qsim in the data.frame Qsim
+      Qsim[[id]][x$ts.index] <- x$OutputsModel[[id]]$Qsim
+      # Routing Qsim to the downstream node
+      if(!is.na(x$InputsModel[[id]]$down)) {
+        x$InputsModel[[x$InputsModel[[id]]$down]]$Qupstream[iTS, id] <-
+          x$OutputsModel[[id]]$Qsim
+      }
+    }
+    x$ts.previous <- x$ts.index
+  }
+  for(id in getSD_Ids(x$InputsModel)) {
+    x$OutputsModel[[id]]$Qsim <- Qsim[[id]]
+  }
+  attr(x$OutputsModel, "Qm3s") <- OutputsModelQsim(x$InputsModel, x$OutputsModel, RunOptions[[1]]$IndPeriod_Run)
+  return(x$OutputsModel)
+}

R/RunModel_Lag.R

+RunModel_Lag <- function(InputsModel, RunOptions, Param) {
+  NParam <- 1
+
+  ##Arguments_check
+  if (!inherits(InputsModel, "InputsModel")) {
+    stop("'InputsModel' must be of class 'InputsModel'")
+  }
+  if (!inherits(InputsModel, "SD")) {
+    stop("'InputsModel' must be of class 'SD'")
+  }
+  if (!inherits(RunOptions, "RunOptions")) {
+    stop("'RunOptions' must be of class 'RunOptions'")
+  }
+  if (!is.vector(Param) | !is.numeric(Param)) {
+    stop("'Param' must be a numeric vector")
+  }
+  if (sum(!is.na(Param)) != NParam) {
+    stop(paste("'Param' must be a vector of length", NParam, "and contain no NA"))
+  }
+  if (is.null(InputsModel$OutputsModel)) {
+    stop(
+      "'InputsModel' should contain an 'OutputsModel' key containing the output of the runoff of the downstream subcatchment"
+    )
+  }
+  if (is.null(InputsModel$OutputsModel$Qsim)) {
+    stop(
+      "'InputsModel$OutputsModel' should contain a key 'Qsim' containing the output of the runoff of the downstream subcatchment"
+    )
+  }
+  if (sum(!is.na(InputsModel$OutputsModel$Qsim)) != length(RunOptions$IndPeriod_Run)) {
+    stop(
+      "'InputsModel$OutputsModel$Qim' should have the same lenght as 'RunOptions$IndPeriod_Run' and contain no NA"
+    )
+  }
+
+  OutputsModel <- InputsModel$OutputsModel
+  OutputsModel$QsimDown <- OutputsModel$Qsim
+
+  if (inherits(InputsModel, "hourly")) {
+    TimeStep <- 60 * 60
+  } else if (inherits(InputsModel, "daily")) {
+    TimeStep <- 60 * 60 * 24
+  } else {
+    stop("'InputsModel' should be of class \"daily\" or \"hourly\"")
+  }
+
+  # propagation time from upstream meshes to outlet
+  PT <- InputsModel$LengthHydro / Param[1L] / TimeStep
+  HUTRANS <- rbind(1 - (PT - floor(PT)), PT - floor(PT))
+
+  NbUpBasins <- length(InputsModel$LengthHydro)
+  LengthTs <- length(OutputsModel$QsimDown)
+  OutputsModel$Qsim <- OutputsModel$QsimDown * InputsModel$BasinAreas[length(InputsModel$BasinAreas)] * 1e3
+
+  IniSD <- RunOptions$IniStates[grep("SD", names(RunOptions$IniStates))]
+  if (length(IniSD) > 0) {
+    if (sum(floor(PT)) + NbUpBasins != length(IniSD)) {
+      stop(
+        sprintf(
+          "SD initial states has a length of %i and a length of %i is required",
+          length(IniSD),
+          sum(floor(PT)) + NbUpBasins
+        )
+      )
+    }
+    IniStates <- lapply(seq_len(NbUpBasins), function(x) {
+      iStart <- 1
+      if (x > 1) {
+        iStart <- iStart + sum(floor(PT[1:x - 1]) + 1)
+      }
+      IniSD[iStart:(iStart + PT[x])]
+    })
+  } else {
+    IniStates <- lapply(seq_len(NbUpBasins), function(x) {
+      rep(0, floor(PT[x] + 1))
+    })
+  }
+  #message("Initstates: ",paste(IniStates, collapse = ", "))
+
+  for (upstream_basin in seq_len(NbUpBasins)) {
+    Qupstream <- c(IniStates[[upstream_basin]],
+                   InputsModel$Qupstream[RunOptions$IndPeriod_Run, upstream_basin])
+    if (!is.na(InputsModel$BasinAreas[upstream_basin])) {
+      # Upstream flow with area needs to be converted to m3 by time step
+      Qupstream <- Qupstream * InputsModel$BasinAreas[upstream_basin] * 1e3
+    }
+    #message("Qupstream[", upstream_basin, "]: ", paste(Qupstream, collapse = ", "))
+    OutputsModel$Qsim <-
+      OutputsModel$Qsim +
+      Qupstream[2:(1 + LengthTs)] * HUTRANS[1, upstream_basin] +
+      Qupstream[1:LengthTs] * HUTRANS[2, upstream_basin]
+  }
+  # Warning for negative flows
+  if (any(OutputsModel$Qsim < 0)) {
+    warning(length(which(OutputsModel$Qsim < 0)), " time steps with negative flow, set to zero.")
+    OutputsModel$Qsim[OutputsModel$Qsim < 0] <- 0
+  }
+  # Convert back Qsim to mm
+  OutputsModel$Qsim <- OutputsModel$Qsim / sum(InputsModel$BasinAreas, na.rm = TRUE) / 1e3
+  #message("Qsim: ",paste(OutputsModel$Qsim, collapse = ", "))
+
+  if ("StateEnd" %in% RunOptions$Outputs_Sim) {
+    OutputsModel$StateEnd$SD <- lapply(seq(NbUpBasins), function(x) {
+      lastTS <- RunOptions$IndPeriod_Run[length(RunOptions$IndPeriod_Run)]
+      InputsModel$Qupstream[(lastTS - floor(PT[x])):lastTS, x]
+    })
+    #message("StateEnd: ",paste(OutputsModel$StateEnd$SD, collapse = ", "))
+  }
+
+  return(OutputsModel)
+}

R/createController.R

+#' Create and add a controller in a supervisor
+#'
+#' @details
+#' `ctrl.id` parameter is a unique id for finding the controller in the supervisor.
+#' If a controller with the same id already exists, it is overwritten by this new one.
+#'
+#' `FUN` parameter should be a function with one [numeric] parameter.
+#' This parameter will receive the measured values of at `Y` locations as input
+#' for the previous time step and returns calculated `U`. These `U` will then be applied
+#' at their location for the current time step of calculation of the model.
+#'
+#' @param supervisor `Supervisor` object, see [CreateSupervisor]
+#' @param ctrl.id [character] id of the controller (see Details)
+#' @param Y [character] location of the controlled and/or measured variables in the model. See [createControl]
+#' @param U [character] location of the command variables in the model. See [createControl]
+#' @param FUN [function] controller logic which calculates `U` from `Y` (see Details)
+#'
+#' @return `Controller`
+#' @export
+#'
+#' @examples
+#' # First create a Supervisor from a model
+#' example("CreateSupervisor")
+#' # A controller which usually releases 0.1 m3/s and provides
+#' # extra release if the downstream flow is below 0.5 m3/s
+#' logicDamRelease <- function(Y) max(0.5 - Y[1], 0.1)
+#' CreateController(sv, "DamRelease", Y = c("54001"), U = c("54095"), FUN = logicDamRelease)
+CreateController <- function(supervisor, ctrl.id, Y, U, FUN){
+
+  if(!is.character(ctrl.id)) stop("Parameter `ctrl.id` should be character")
+
+  FUN <- match.fun(FUN)
+
+  ctrlr <- list(
+    id = ctrl.id,
+    U = createControl(U),
+    Unames = U,
+    Y = createControl(Y),
+    Ynames = Y,
+    FUN = FUN
+  )
+  class(ctrlr) <- c("Controller", class(ctrlr))
+
+  # Function called from Supervisor environment
+  #environment(ctrlr$FUN) <- supervisor
+  if(!is.null(supervisor$controllers[[ctrl.id]])) {
+    warning("Controller '", ctrl.id, "' already exists in the supervisor: overwriting")
+  }
+  supervisor$controllers[[ctrl.id]] <- ctrlr
+  message("The controller has been added to the supervisor")
+  invisible(ctrlr)
+}
+
+#' Create a list of controls for command (U) and controlled variables (Y)
+#'
+#' @param locations vector of [character] containing the location of the variable in the model (see details)
+#'
+#' @return a [matrix] with each column is the location of the variables and the rows
+#' the values of the variable for the current time steps (empty by default)
+#' @export
+#'
+#' @examples
+#' # For pointing the discharge at the oulet of basins "54095" and "54002"
+#' createControl(c("54095", "54002"))
+createControl <- function(locations) {
+  if(!is.character(locations)) {
+    stop("Parameter `locations` should be character")
+  }
+  m <- matrix(NA, ncol = length(locations), nrow = 0)
+  return(m)
+}

R/plot.Qm3s.R

+#' Plot a `Qm3s` object (time series of simulated flows)
+#'
+#' @param x a [data.frame] with a first column with [POSIXt] dates and followings columns with flows at each node of the network
+#' @param type 1-character string (See [plot.default]), default "l"
+#' @param xlab a label for the x axis, defaults to "Date"
+#' @param ylab a label for the y axis, defaults to "Flow (m3/s)"
+#' @param main a main title for the plot, defaults to "Simulated flows"
+#' @param col plotting color (See [par]), defaults to rainbow colors
+#' @param legend See parameter `legend` of [legend]. Set to [NULL] to not display the legend
+#' @param legend.cex `cex` parameter for the text of the legend (See [par])
+#' @param lty The line type (See [par])
+#' @param ... Further arguments to pass to the [matplot] functions
+#'
+#' @importFrom grDevices rainbow
+#' @importFrom graphics matplot
+#' @export
+#'
+plot.Qm3s <- function(x,
+                      type = 'l',
+                      xlab = "Date",
+                      ylab = "Flow (m3/s)",
+                      main = "Simulated flows",
+                      col = rainbow(ncol(x) - 1),
+                      legend = colnames(x)[-1],
+                      legend.cex = 0.7,
+                      lty = 1,
+                      ...) {
+  matplot(
+    x$DatesR,
+    x[, -1],
+    type = type,
+    lty = lty,
+    xlab = xlab,
+    ylab = ylab,
+    main = main,
+    col = col, ...
+  )
+  if(!is.null(legend)) {
+    legend('topright',
+           legend = legend,
+           cex = legend.cex,
+           lty = lty,
+           col = col)
+  }
+}

R/utils.R

+#' Id of sub-basins using SD model
+#'
+#' @param InputsModel `GRiwrmInputsModel` object
+#'
+#' @return [character] IDs of the sub-basins using SD model
+#'
+getSD_Ids <- function(InputsModel) {
+  if (!inherits(InputsModel, "GRiwrmInputsModel")) {
+    stop("Argument `InputsModel` should be of class GRiwrmInputsModel")
+  }
+  bSDs <- sapply(InputsModel, function (IM) {
+    inherits(IM, "SD")
+  })
+  names(InputsModel)[bSDs]
+}
+
+#' Id of sub-basins not using SD model
+#'
+#' @param InputsModel `GRiwrmInputsModel` object
+#'
+#' @return [character] IDs of the sub-basins not using SD model
+#'
+getNoSD_Ids <- function(InputsModel) {
+  if (!inherits(InputsModel, "GRiwrmInputsModel")) {
+    stop("Argument `InputsModel` should be of class GRiwrmInputsModel")
+  }
+  bSDs <- sapply(InputsModel, function (IM) {
+    !inherits(IM, "SD")
+  })
+  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
+#' @param sv a `Supervisor` (See [CreateSupervisor])
+#'
+#' @return [numeric] retrieved data at the location
+getDataFromLocation <- function(loc, sv) {
+  if (length(grep("\\[[0-9]+\\]$", loc)) > 0) {
+    stop("Reaching output of other controller is not implemented yet")
+  } else {
+    node <- sv$griwrm$down[sv$griwrm$id == loc]
+    sv$InputsModel[[node]]$Qupstream[sv$ts.index0 + sv$ts.previous, loc]
+  }
+}
+
+
+#' Write data to model input for the current time step
+#'
+#' @param ctrlr a `Controller` object (See [CreateController])
+#' @param sv `Supervisor` (See [CreateSupervisor])
+#'
+#' @return [NULL]
+setDataToLocation <- function(ctrlr, sv) {
+  l <- lapply(seq(length(ctrlr$Unames)), function(i) {
+    node <- sv$griwrm$down[sv$griwrm$id == ctrlr$Unames[i]]
+    # limit U size to the number of simulation time steps of the current supervision time step
+    U <- ctrlr$U[seq.int(length(sv$ts.index)),i]
+    # ! Qupstream contains warm up period and run period => the index is shifted
+    sv$InputsModel[[node]]$Qupstream[sv$ts.index0 + sv$ts.index, ctrlr$Unames[i]] <- U
+  })
+}
+
+
+#' Do the supervision for the current time step
+#'
+#' @param supervisor `Supervisor` (See [CreateSupervisor])
+#'
+doSupervision <- function(supervisor) {
+  for (id in names(supervisor$controllers)) {
+    supervisor$controller.id <- id
+    # Read Y from locations in the model
+    supervisor$controllers[[id]]$Y <- do.call(
+      cbind,
+      lapply(supervisor$controllers[[id]]$Ynames, getDataFromLocation, sv = supervisor)
+    )
+    # Run logic
+    supervisor$controllers[[id]]$U <-
+      supervisor$controllers[[id]]$FUN(supervisor$controllers[[id]]$Y)
+    # Write U to locations in the model
+    setDataToLocation(supervisor$controllers[[id]], sv = supervisor)
+  }
+}
+
+
+#' Check the parameters of RunModel methods
+#'
+#' Stop the execution if an error is detected.
+#'
+#' @param InputsModel a `GRiwrmInputsModel` object (See [CreateInputsModel.GRiwrm])
+#' @param RunOptions a `GRiwrmRunOptions` object (See [CreateRunOptions.GRiwrmInputsModel])
+#' @param Param a [list] of [numeric] containing model parameters of each node of the network
+#'
+checkRunModelParameters <- function(InputsModel, RunOptions, Param) {
+  if(!inherits(InputsModel, "GRiwrmInputsModel")) stop("`InputsModel` parameter must of class 'GRiwrmRunoptions' (See ?CreateRunOptions.GRiwrmInputsModel)")
+  if(!inherits(RunOptions, "GRiwrmRunOptions")) stop("Argument `RunOptions` parameter must of class 'GRiwrmRunOptions' (See ?CreateRunOptions.GRiwrmInputsModel)")
+  if(!is.list(Param) || !all(names(InputsModel) %in% names(Param))) stop("Argument `Param` must be a list with names equal to nodes IDs")
+}
+
+
+#' Create a data.frame with simulated flows at each nodes of the [GRiwrm] object
+#'
+#' @details
+#' This function can only be called inside [RunModel.GRiwrmInputsModel] or [RunModel.Supervisor]
+#' because it needs a `GRiwrmInputsModel` object internally modified by these functions
+#' (`Qupstream` updated with simulated flows).
+#'
+#' @param InputsModel a `GRiwrmInputsModel` object created by [CreateInputsModel.GRiwrm]
+#' @param OutputsModel a `GRiwrmOutputsModel` object created by [RunModel.GRiwrmInputsModel] or [RunModel.Supervisor]
+#' @param IndPeriod_Run an [integer] vector (See [airGR::CreateRunOptions])
+#'
+#' @return a [data.frame] containing the simulated flows (in m3/time step) structured with the following columns:
+#' - 'DatesR' containing the timestamps of the time series
+#' - one column by node with the simulated flows
+#'
+OutputsModelQsim <- function(InputsModel, OutputsModel, IndPeriod_Run) {
+  griwrm <- attr(InputsModel, "GRiwrm")
+  # Get simulated flow for each node
+  # Flow for each node is available in InputsModel$Qupstream except for the downstream node
+  upperNodes <- griwrm$id[!is.na(griwrm$down)]
+  lQsim <- lapply(
+    upperNodes,
+    function(x, griwrm, IndPeriod_Run) {
+      node <- griwrm$down[griwrm$id == x]
+      InputsModel[[node]]$Qupstream[IndPeriod_Run, x]
+    },
+    griwrm = griwrm, IndPeriod_Run = IndPeriod_Run
+  )
+  names(lQsim) <- upperNodes
+  # Flow of the downstream node is only available in OutputsModel[[node]]$Qsim
+  downNode <- names(InputsModel)[length(InputsModel)]
+  lQsim[[downNode]] <- OutputsModel[[downNode]]$Qsim
+
+  # Conversion to m3/s
+  lQsim <- lapply(
+    names(lQsim),
+    function(x) {
+      i <- which(griwrm$id == x)
+      if(is.na(griwrm$area[i])) { # m3/time step => m3/s
+        return(lQsim[[x]] / attr(InputsModel, "TimeStep"))
+      } else { # mm/time step => m3/s
+        return(lQsim[[x]] * griwrm$area[i] * 1E3 / attr(InputsModel, "TimeStep"))
+      }
+    }
+  )
+  names(lQsim) <- c(upperNodes, downNode)
+  dfQsim <- cbind(data.frame(DatesR = as.POSIXct(InputsModel[[1]]$DatesR[IndPeriod_Run])),
+                  do.call(cbind,lQsim))
+  class(dfQsim) <- c("Qm3s", class(dfQsim)) # For S3 methods
+  return(dfQsim)
+}

tests/testthat/test-RunModel.R

+context("RunModel.Supervisor")
+
+# Load data
+data(Severn)
+
+# Network configuration
+nodes <- Severn$BasinsInfo[c(1,2,5), c("gauge_id", "downstream_id", "distance_downstream", "area")]
+nodes$distance_downstream <- nodes$distance_downstream * 1000 # Conversion km -> m
+nodes$model <- NA
+nodes$model[1] <- "RunModel_GR4J"
+griwrm <- GRiwrm(nodes, list(id = "gauge_id", down = "downstream_id", length = "distance_downstream"))
+
+# InputsModel
+DatesR <- Severn$BasinsObs[[1]]$DatesR
+PrecipTot <- cbind(sapply(Severn$BasinsObs, function(x) {x$precipitation}))
+PotEvapTot <- cbind(sapply(Severn$BasinsObs, function(x) {x$peti}))
+Precip <- ConvertMeteoSD(griwrm, PrecipTot)
+PotEvap <- ConvertMeteoSD(griwrm, PotEvapTot)
+Qobs <- cbind(sapply(Severn$BasinsObs, function(x) {x$discharge_spec}))
+InputsModel <- CreateInputsModel(griwrm, DatesR, Precip, PotEvap, Qobs)
+
+# RunOptions
+nTS <- 365
+IndPeriod_Run <- seq(
+  length(InputsModel[[1]]$DatesR) - nTS + 1,
+  length(InputsModel[[1]]$DatesR)
+)
+IndPeriod_WarmUp = seq(IndPeriod_Run[1]-366,IndPeriod_Run[1]-1)
+RunOptions <- CreateRunOptions(
+  InputsModel = InputsModel,
+  IndPeriod_WarmUp = IndPeriod_WarmUp,
+  IndPeriod_Run = IndPeriod_Run
+)
+
+# RunModel.GRiwrmInputsModel
+Param <- list("54057" = c(0.727,  175.493,   -0.082,    0.029,    4.654))
+OM_GriwrmInputs <- RunModel(
+  InputsModel,
+  RunOptions = RunOptions,
+  Param = Param
+)
+
+test_that("RunModelSupervisor with no regulation should returns same results as RunModel.GRiwrmInputsModel", {
+  sv <- CreateSupervisor(InputsModel)
+  OM_Supervisor <- RunModel(
+    sv,
+    RunOptions = RunOptions,
+    Param = Param
+  )
+  expect_equal(OM_Supervisor[["54057"]]$Qsim, OM_GriwrmInputs[["54057"]]$Qsim)
+})
+
+# Add 2 nodes to the network
+griwrm2 <- rbind(griwrm,
+                 data.frame(
+                   id = c("R1", "R2"),
+                   down = "54057",
+                   length = 100000,
+                   area = NA,
+                   model = NA
+                 ))
+# Add Qobs for the 2 new nodes and create InputsModel
+Qobs2 <- cbind(Qobs, matrix(data = rep(0, 2*nrow(Qobs)), ncol = 2))
+colnames(Qobs2) <- c(colnames(Qobs2)[1:6], "R1", "R2")
+InputsModel <- CreateInputsModel(griwrm2, DatesR, Precip, PotEvap, Qobs2)
+
+test_that("RunModelSupervisor with two regulations that cancel each other out should returns same results as RunModel.GRiwrmInputsModel", {
+  # Create Supervisor
+  sv <- CreateSupervisor(InputsModel)
+  # Function to withdraw half of the measured flow
+  fWithdrawal <- function(y) { -y/2 }
+  # Function to release half of the the measured flow
+  fRelease <- function(y) { y/2 }
+  # Controller that withdraw half of the flow measured at node "54002" at location "R1"
+  CreateController(sv, "Withdrawal", Y = c("54002"), U = c("R1"), FUN = fWithdrawal)
+  # Controller that release half of the flow measured at node "54002" at location "R2"
+  CreateController(sv, "Release", Y = c("54002"), U = c("R2"), FUN = fRelease)
+
+  OM_Supervisor <- RunModel(
+    sv,
+    RunOptions = RunOptions,
+    Param = Param
+  )
+  expect_equal(OM_Supervisor[["54057"]]$Qsim, OM_GriwrmInputs[["54057"]]$Qsim)
+})
+
+test_that("RunModelSupervisor with multi time steps controller, two regulations in 1 centralised controller that cancel each other out should returns same results as RunModel.GRiwrmInputsModel", {
+  sv <- CreateSupervisor(InputsModel, TimeStep = 10L)
+  fEverything <- function(y) {
+    matrix(c(y[,1]/2, -y[,1]/2), ncol = 2)
+  }
+  CreateController(sv, "Everything", Y = c("54002", "54032"), U = c("R1", "R2"), FUN = fEverything)
+  OM_Supervisor <- RunModel(
+    sv,
+    RunOptions = RunOptions,
+    Param = Param
+  )
+  expect_equal(OM_Supervisor[["54057"]]$Qsim, OM_GriwrmInputs[["54057"]]$Qsim)
+})