v1.6.1.12 fix: QobsUpstr should use RunOptions$IndPeriod_Run index in RunModel

- Add simple tests on ru of SD model
- Add also a control on the Qupstream series lenght

Refs #34

.gitignore

@@ -34,7 +34,7 @@ packrat/lib*/
 /*.Rcheck/
 
 # RStudio files
-.Rproj.user/
+.Rproj.user
 
 # produced vignettes
 vignettes/*.html

R/CreateInputsModel.R

@@ -207,6 +207,9 @@ CreateInputsModel <- function(FUN_MOD,
       if (ncol(QobsUpstr)+1 != ncol(BasinAreas)) {
         stop("'BasinAreas' must have one column more than 'QobsUpstr' and 'LengthHydro'")
       }
+      if (nrow(QobsUpstr) != LLL) {
+        stop("'QobsUpstr' must have same number of rows as 'DatesR' length")
+      }
       if (nrow(LengthHydro) != 1 | nrow(BasinAreas) != 1) {
         stop("'LengthHydro' and 'BasinAreas' must have only one row")
       }

R/RunModel.R

@@ -26,12 +26,13 @@ RunModel <- function (InputsModel, RunOptions, Param, FUN_MOD) {
     OutputsModelDown$Qsim <- OutputsModelDown$QsimDown * InputsModel$BasinAreas[length(InputsModel$BasinAreas)] / AreaTot
     
     for (upstream_basin in seq_len(NbUpBasins)) {
+      QobsUpstr <- InputsModel$QobsUpstr[RunOptions$IndPeriod_Run, upstream_basin]
       OutputsModelDown$Qsim <- OutputsModelDown$Qsim + 
         c(rep(0, floor(PT[upstream_basin])), 
-          InputsModel$QobsUpstr[(1 + floor(PT[upstream_basin])):LengthTs, upstream_basin]) *
+          QobsUpstr[(1 + floor(PT[upstream_basin])):LengthTs]) *
         HUTRANS[1, upstream_basin] * InputsModel$BasinAreas[upstream_basin] / AreaTot + 
         c(rep(0, floor(PT[upstream_basin] + 1)), 
-          InputsModel$QobsUpstr[(2 + floor(PT[upstream_basin])):LengthTs, upstream_basin]) *
+          QobsUpstr[(2 + floor(PT[upstream_basin])):LengthTs]) *
         HUTRANS[2, upstream_basin] * InputsModel$BasinAreas[upstream_basin] / AreaTot
     }
     

tests/testthat/test-RunModel_LAG.R

+context("RunModel_LAG")
+
+data(L0123001)
+
+
+test_that("'BasinAreas' must have one column more than 'QobsUpstr' and 'LengthHydro'", {
+    expect_error(
+        InputsModel <- CreateInputsModel(
+            FUN_MOD = RunModel_GR4J, DatesR = BasinObs$DatesR,
+            Precip = BasinObs$P, PotEvap = BasinObs$E,
+            QobsUpstr = matrix(BasinObs$Qmm * 2,ncol=1),
+            LengthHydro = matrix(c(1),nrow=1),
+            BasinAreas = matrix(c(1),nrow=1)
+        ),
+        regexp = "'BasinAreas' must have one column more than 'QobsUpstr' and 'LengthHydro'"
+    )
+})
+
+test_that("'BasinAreas' must have one column more than 'QobsUpstr' and 'LengthHydro'", {
+    expect_error(
+        InputsModel <- CreateInputsModel(
+            FUN_MOD = RunModel_GR4J, DatesR = BasinObs$DatesR,
+            Precip = BasinObs$P, PotEvap = BasinObs$E,
+            QobsUpstr = matrix(BasinObs$Qmm, ncol = 1),
+            LengthHydro = matrix(c(1), nrow = 1),
+            BasinAreas = matrix(c(1, 2),nrow = 1)
+        ),
+        regexp = "'QobsUpstr' cannot contain any NA value"
+    )
+})
+
+QobsUpstr = BasinObs$Qmm
+QobsUpstr[is.na(QobsUpstr)] = mean(QobsUpstr, na.rm = TRUE)
+
+InputsModel <- CreateInputsModel(
+    FUN_MOD = RunModel_GR4J, DatesR = BasinObs$DatesR,
+    Precip = BasinObs$P, PotEvap = BasinObs$E,
+    QobsUpstr = matrix(QobsUpstr,ncol=1),
+    LengthHydro = matrix(c(1),nrow=1),
+    BasinAreas = matrix(c(BasinInfo$BasinArea,BasinInfo$BasinArea),nrow=1)
+)
+
+Ind_Run <- seq(
+    which(format(BasinObs$DatesR, format = "%Y-%m-%d")=="1990-01-01"),
+    which(format(BasinObs$DatesR, format = "%Y-%m-%d")=="1999-12-31")
+)
+
+RunOptions <- CreateRunOptions(
+    FUN_MOD = RunModel_GR4J,
+    InputsModel = InputsModel, IndPeriod_Run = Ind_Run
+)
+
+Param = c(257.237556, 1.012237, 88.234673, 2.207958) #  From vignettes/V01_get_started
+
+OutputsGR4JOnly <- RunModel_GR4J(InputsModel = InputsModel, RunOptions = RunOptions, Param = Param)
+
+
+test_that("Upstream basin with nil area should return same Qdown as GR4J alone", {
+  UpstBasinArea = InputsModel$BasinAreas[1,1]
+  InputsModel$BasinAreas[1,1] <<- 0
+  OutputsSD <- RunModel(InputsModel, RunOptions, Param = c(Param, 1), FUN_MOD = RunModel_GR4J)
+  expect_equal(OutputsGR4JOnly$Qsim, OutputsSD$Qsim)
+  InputsModel$BasinAreas[1,1] <<- UpstBasinArea
+})
+
+test_that("Downstream basin with nil area and nul upstream length should return same Qdown as Qupstream alone", {
+  InputsModel <- CreateInputsModel(
+    FUN_MOD = RunModel_GR4J, DatesR = BasinObs$DatesR,
+    Precip = BasinObs$P, PotEvap = BasinObs$E,
+    QobsUpstr = matrix(QobsUpstr,ncol=1),
+    LengthHydro = matrix(c(0),nrow=1),
+    BasinAreas = matrix(c(BasinInfo$BasinArea,0),nrow=1)
+  )
+  OutputsSD <- RunModel(InputsModel, RunOptions, Param = c(Param, 1), FUN_MOD = RunModel_GR4J)
+  expect_equal(OutputsSD$Qsim, QobsUpstr[Ind_Run])
+})
+
+test_that("1 input with lag of 1 time step delay out gives an output delayed of one time step", {
+    QlsGR4Only <- OutputsGR4JOnly$Qsim * InputsModel$BasinAreas[2] * 1E6 / 86400
+    ParamSD = c(Param, InputsModel$LengthHydro * 1000 / (24 * 60 * 60))
+    OutputsSD <- RunModel(InputsModel, RunOptions, Param = ParamSD, FUN_MOD = RunModel_GR4J)
+    QlsSdSim <- OutputsSD$Qsim * sum(InputsModel$BasinAreas) * 1E6 / 86400
+    QlsUpstLagObs <- c(0, QobsUpstr[Ind_Run[1:(length(Ind_Run)-1)] + 1]) * InputsModel$BasinAreas[1] * 1E6 / 86400
+    expect_equal(QlsSdSim - QlsGR4Only, QlsUpstLagObs)
+})