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

Refs #88

DESCRIPTION

@@ -37,5 +37,5 @@ VignetteBuilder:
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.1
 Language: en-US

R/Calibration.GRiwrmInputsModel.R

@@ -54,7 +54,7 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
       IM$FUN_MOD <- "RunModel_Ungauged"
       attr(RunOptions[[id]], "GRiwrmRunOptions") <- l$RunOptions
     } else {
-      if(useUpstreamQsim && any(IM$UpstreamIsRunoff)) {
+      if (useUpstreamQsim && any(IM$UpstreamIsRunoff)) {
         # Update InputsModel$Qupstream with simulated upstream flows
         IM <- UpdateQsimUpstream(IM, RunOptions[[id]], OutputsModel)
       }
@@ -73,20 +73,18 @@ Calibration.GRiwrmInputsModel <- function(InputsModel,
       g <- attr(IM, "GRiwrm")
       Ids <- g$id[g$donor == id & !is.na(g$model)]
       # Extract the X4 calibrated for the whole intermediate basin
-      PS <- attr(IM[[id]], "ParamSettings")
-      if(PS$hasX4) {
-        X4 <- OutputsCalib[[id]]$ParamFinalR[PS$iX4] # Global parameter
+      if(IM[[id]]$model$hasX4) {
+        X4 <- OutputsCalib[[id]]$ParamFinalR[IM[[id]]$model$iX4] # Global parameter
         subBasinAreas <- calcSubBasinAreas(IM)
       }
       for (uId in Ids) {
         # Add OutputsCalib for ungauged nodes
         OutputsCalib[[uId]] <- OutputsCalib[[id]]
         # Copy parameters and transform X4 relatively to the sub-basin area
-        PS <- attr(IM[[uId]], "ParamSettings")
         OutputsCalib[[uId]]$ParamFinalR <-
-          OutputsCalib[[uId]]$ParamFinalR[PS$Indexes]
-        if(PS$hasX4) {
-          OutputsCalib[[uId]]$ParamFinalR[PS$iX4] <-
+          OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$indexParamUngauged]
+        if(IM[[id]]$model$hasX4) {
+          OutputsCalib[[uId]]$ParamFinalR[IM[[uId]]$model$iX4] <-
             X4 * (subBasinAreas[uId] / sum(subBasinAreas)) ^ 0.3
         }
       }
@@ -195,14 +193,7 @@ updateParameters4Ungauged <- function(GaugedId,
         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
   class(InputsModel) <- c("InputsModel", class(InputsModel))
 
@@ -256,10 +247,9 @@ RunModel_Ungauged <- function(InputsModel, RunOptions, Param) {
   SBVI <- sum(calcSubBasinAreas(InputsModel))
   # Compute Param for each sub-basin
   P <- lapply(InputsModel, function(IM) {
-    PS <- attr(IM, "ParamSettings")
-    p <- Param[PS$Indexes]
-    if(PS$hasX4) {
-      p[PS$iX4] <- Param[PS$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / SBVI) ^ 0.3
+    p <- Param[IM$model$indexParamUngauged]
+    if(IM$model$hasX4) {
+      p[IM$model$iX4] <- Param[IM$model$iX4] * (IM$BasinAreas[length(IM$BasinAreas)] / SBVI) ^ 0.3
     }
     return(p)
   })

R/CreateInputsModel.GRiwrm.R

@@ -194,10 +194,13 @@ CreateOneGRiwrmInputsModel <- function(id, griwrm, ..., Qobs) {
 
   # Add the model function
   InputsModel$FUN_MOD <- FUN_MOD
+  featModel <- .GetFeatModel(InputsModel)
   InputsModel$isUngauged <- griwrm$model[griwrm$id == id] == "Ungauged"
   InputsModel$gaugedId <- griwrm$donor[griwrm$id == id]
   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)
 }
 
@@ -282,3 +285,24 @@ hasUngaugedNodes <- function(id, griwrm) {
   }
   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)
+}