-
Dorchies David authored6a2b07d6
#' Create InputsModel object for a **airGRiwrm** network
#'
#' @param x GRiwrm object describing the diagram of the semi-distributed model, see \code{[GRiwrm]}.
#' @param DatesR Vector of POSIXt observation time steps.
#' @param Precip Matrix or data frame of numeric containing precipitation in mm. Column names correspond to node IDs.
#' @param PotEvap Matrix or data frame of numeric containing potential evaporation in mm. Column names correspond to node IDs.
#' @param Qobs Matrix or data frame of numeric containing potential observed flow in mm. Column names correspond to node IDs.
#' @param verbose (optional) boolean indicating if the function is run in verbose mode or not, default = \code{TRUE}
#' @param ... further arguments passed to \code{\link[airGR]{CreateInputsModel}}.
#'
#' @return GRiwrmInputsModel object equivalent to **airGR** InputsModel object for a semi-distributed model (See \code{\link[airGR]{CreateInputsModel}})
#' @export
CreateInputsModel.GRiwrm <- function(x, DatesR, Precip, PotEvap, Qobs, verbose = TRUE, ...) {
InputsModel <- CreateEmptyGRiwrmInputsModel()
Qobs[is.na(Qobs)] <- -99 # airGRCreateInputsModel doesn't accept NA values
for(id in getNodeRanking(x)) {
if(verbose) cat("CreateInputsModel.griwrm: Treating sub-basin", id, "...\n")
InputsModel[[id]] <- CreateOneGRiwrmInputsModel(
id, x, DatesR,Precip[,id], PotEvap[,id], Qobs, ...
)
}
return(InputsModel)
}
#' Create an empty InputsModel object for **airGRiwrm** nodes
#'
#' @return \emph{GRiwrmInputsModel} empty object
CreateEmptyGRiwrmInputsModel <- function() {
InputsModel <- list()
class(InputsModel) <- append(class(InputsModel), "GRiwrmInputsModel")
return(InputsModel)
}
#' Create one InputsModel for a **airGRiwrm** node
#'
#' @param id string of the node identifier
#' @param griwrm See \code{[GRiwrm]}.
#' @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 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.
CreateOneGRiwrmInputsModel <- function(id, griwrm, DatesR, Precip, PotEvap, Qobs) {
node <- griwrm[griwrm$id == id,]
FUN_MOD <- griwrm$model[griwrm$id == id]
# Set hydraulic parameters
UpstreamNodes <- griwrm$id[griwrm$down == id & !is.na(griwrm$down)]
Qupstream <- NULL
LengthHydro <- NULL
BasinAreas <- NULL
if(length(UpstreamNodes) > 0) {
# Sub-basin with hydraulic routing
Qupstream <- Qobs[ , UpstreamNodes, drop=FALSE]
LengthHydro <- griwrm$length[griwrm$id %in% UpstreamNodes]
names(LengthHydro) <- UpstreamNodes
BasinAreas <- c(
griwrm$area[griwrm$id %in% UpstreamNodes],
node$area - sum(griwrm$area[griwrm$id %in% UpstreamNodes], na.rm = TRUE)
)
names(BasinAreas) <- c(UpstreamNodes, id)
}
# Set model inputs with the **airGR** function
71727374757677787980818283848586878889909192
InputsModel <- CreateInputsModel(
FUN_MOD,
DatesR = DatesR,
Precip = Precip,
PotEvap = PotEvap,
Qupstream = Qupstream,
LengthHydro = LengthHydro,
BasinAreas = BasinAreas
)
# Add Identifiers of connected nodes in order to be able to update them with simulated flows
InputsModel$id <- id
if(length(UpstreamNodes) > 0) {
InputsModel$UpstreamNodes <- UpstreamNodes
InputsModel$UpstreamIsRunoff <- !is.na(griwrm$model[match(UpstreamNodes, griwrm$id)])
}
# Add the model function
InputsModel$FUN_MOD <- FUN_MOD
return(InputsModel)
}