Commit 6e6507d1 authored by David's avatar David
Browse files

refactor: add model features to InputsModel for simplification of X4 parameter management

Refs #88
2 merge requests!93Draft: Version 0.7.0,!45Resolve "Regularisation: taking into account X4 transformation"
Pipeline #38682 canceled with stage
in 1 minute and 14 seconds
Showing with 36 additions and 22 deletions
+36 -22
...@@ -37,5 +37,5 @@ VignetteBuilder: ...@@ -37,5 +37,5 @@ VignetteBuilder:
Encoding: UTF-8 Encoding: UTF-8
LazyData: true LazyData: true
Roxygen: list(markdown = TRUE) Roxygen: list(markdown = TRUE)
RoxygenNote: 7.2.0 RoxygenNote: 7.2.1
Language: en-US Language: en-US
...@@ -54,7 +54,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, ...@@ -54,7 +54,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
IM$FUN_MOD <- "RunModel_Ungauged" IM$FUN_MOD <- "RunModel_Ungauged"
attr(RunOptions[[id]], "GRiwrmRunOptions") <- l$RunOptions attr(RunOptions[[id]], "GRiwrmRunOptions") <- l$RunOptions
} else { } else {
if(useUpstreamQsim && any(IM$UpstreamIsRunoff)) { if (useUpstreamQsim && any(IM$UpstreamIsRunoff)) {
# Update InputsModel$Qupstream with simulated upstream flows # Update InputsModel$Qupstream with simulated upstream flows
IM <- UpdateQsimUpstream(IM, RunOptions[[id]], OutputsModel) IM <- UpdateQsimUpstream(IM, RunOptions[[id]], OutputsModel)
} }
...@@ -73,20 +73,18 @@ Calibration.GRiwrmInputsModel <- function(InputsModel, ...@@ -73,20 +73,18 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
g <- attr(IM, "GRiwrm") g <- attr(IM, "GRiwrm")
Ids <- g$id[g$donor == id & !is.na(g$model)] Ids <- g$id[g$donor == id & !is.na(g$model)]
# Extract the X4 calibrated for the whole intermediate basin # Extract the X4 calibrated for the whole intermediate basin
PS <- attr(IM[[id]], "ParamSettings") if(IM[[id]]$model$hasX4) {
if(PS$hasX4) { X4 <- OutputsCalib[[id]]$ParamFinalR[IM[[id]]$model$iX4] # Global parameter
X4 <- OutputsCalib[[id]]$ParamFinalR[PS$iX4] # Global parameter
subBasinAreas <- calcSubBasinAreas(IM) subBasinAreas <- calcSubBasinAreas(IM)
} }
for (uId in Ids) { for (uId in Ids) {
# Add OutputsCalib for ungauged nodes # Add OutputsCalib for ungauged nodes
OutputsCalib[[uId]] <- OutputsCalib[[id]] OutputsCalib[[uId]] <- OutputsCalib[[id]]
# Copy parameters and transform X4 relatively to the sub-basin area # Copy parameters and transform X4 relatively to the sub-basin area
PS <- attr(IM[[uId]], "ParamSettings")
OutputsCalib[[uId]]$ParamFinalR <- OutputsCalib[[uId]]$ParamFinalR <-
OutputsCalib[[uId]]$ParamFinalR[PS$Indexes] OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged]
if(PS$hasX4) { if(IM[[id]]$model$hasX4) {
OutputsCalib[[uId]]$ParamFinalR[PS$iX4] <- OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <-
X4 * (subBasinAreas[uId] / sum(subBasinAreas)) ^ 0.3 X4 * (subBasinAreas[uId] / sum(subBasinAreas)) ^ 0.3
} }
} }
...@@ -195,14 +193,7 @@ updateParameters4Ungauged <- function(GaugedId, ...@@ -195,14 +193,7 @@ updateParameters4Ungauged <- function(GaugedId,
rep(FALSE, length(InputsModel[[id]]$UpstreamIsRunoff)) rep(FALSE, length(InputsModel[[id]]$UpstreamIsRunoff))
} }
} }
# Add extra info for Param processing
nbParam <- RunOptions[[GaugedId]]$FeatFUN_MOD$NbParam
for (id in names(InputsModel)) {
attr(InputsModel[[id]], "ParamSettings") <-
list(Indexes = ifelse(inherits(InputsModel[[id]], "SD"), 1, 2):nbParam,
hasX4 = grepl("RunModel_GR[456][HJ]", InputsModel[[id]]$FUN_MOD),
iX4 = ifelse(inherits(InputsModel[[id]], "SD"), 5, 4))
}
# Add class InputsModel for airGR::Calibration checks # Add class InputsModel for airGR::Calibration checks
class(InputsModel) <- c("InputsModel", class(InputsModel)) class(InputsModel) <- c("InputsModel", class(InputsModel))
...@@ -256,10 +247,9 @@ RunModel_Ungauged <- function(InputsModel, RunOptions, Param) { ...@@ -256,10 +247,9 @@ RunModel_Ungauged <- function(InputsModel, RunOptions, Param) {
SBVI <- sum(calcSubBasinAreas(InputsModel)) SBVI <- sum(calcSubBasinAreas(InputsModel))
# Compute Param for each sub-basin # Compute Param for each sub-basin
P <- lapply(InputsModel, function(IM) { P <- lapply(InputsModel, function(IM) {
PS <- attr(IM, "ParamSettings") p <- Param[IM$model$indexParamUngauged]
p <- Param[PS$Indexes] if(IM$model$hasX4) {
if(PS$hasX4) { p[IM$model$iX4] <- Param[IM$model$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / SBVI) ^ 0.3
p[PS$iX4] <- Param[PS$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / SBVI) ^ 0.3
} }
return(p) return(p)
}) })
......
...@@ -194,10 +194,13 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs) { ...@@ -194,10 +194,13 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs) {
# Add the model function # Add the model function
InputsModel$FUN_MOD <- FUN_MOD InputsModel$FUN_MOD <- FUN_MOD
featModel <- .GetFeatModel(InputsModel)
InputsModel$isUngauged <- griwrm$model[griwrm$id == id] == "Ungauged" InputsModel$isUngauged <- griwrm$model[griwrm$id == id] == "Ungauged"
InputsModel$gaugedId <- griwrm$donor[griwrm$id == id] InputsModel$gaugedId <- griwrm$donor[griwrm$id == id]
InputsModel$hasUngaugedNodes <- hasUngaugedNodes(id, griwrm) InputsModel$hasUngaugedNodes <- hasUngaugedNodes(id, griwrm)
InputsModel$model <- list(indexParamUngauged = ifelse(inherits(InputsModel, "SD"), 0, 1) + seq.int(featModel$NbParam),
hasX4 = grepl("RunModel_GR[456][HJ]", FUN_MOD),
iX4 = ifelse(inherits(InputsModel, "SD"), 5, 4))
return(InputsModel) return(InputsModel)
} }
...@@ -282,3 +285,24 @@ hasUngaugedNodes <- function(id, griwrm) { ...@@ -282,3 +285,24 @@ hasUngaugedNodes <- function(id, griwrm) {
} }
return(FALSE) return(FALSE)
} }
#' function to extract model features partially copied from airGR:::.GetFeatModel
#' @noRd
.GetFeatModel <- function(InputsModel) {
path <- system.file("modelsFeatures/FeatModelsGR.csv", package = "airGR")
FeatMod <- read.table(path, header = TRUE, sep = ";", stringsAsFactors = FALSE)
NameFunMod <- ifelse(test = FeatMod$Pkg %in% "airGR",
yes = paste("RunModel", FeatMod$NameMod, sep = "_"),
no = FeatMod$NameMod)
IdMod <- which(sapply(NameFunMod, FUN = function(x) identical(InputsModel$FUN_MOD, x)))
if (length(IdMod) < 1) {
stop("'FUN_MOD' must be one of ", paste(NameFunMod, collapse = ", "))
}
FeatMod <- as.list(FeatMod[IdMod, ])
FeatMod$IsSD <- inherits(InputsModel, "SD")
if (FeatMod$IsSD) {
FeatMod$NbParam <- FeatMod$NbParam + 1
}
return(FeatMod)
}
Supports Markdown
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