Commit 67ce1ead authored by Dorchies David's avatar Dorchies David
Browse files

V1.6.1.16: refactor: use vectors for LengthHydro and BasinAreas instead of matrices

Refs #34
parent e974451b
Pipeline #13361 passed with stages
in 11 minutes and 53 seconds
Package: airGR Package: airGR
Type: Package Type: Package
Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling Title: Suite of GR Hydrological Models for Precipitation-Runoff Modelling
Version: 1.6.1.15 Version: 1.6.1.16
Date: 2020-06-04 Date: 2020-06-04
Authors@R: c( Authors@R: c(
person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")), person("Laurent", "Coron", role = c("aut", "trl"), comment = c(ORCID = "0000-0002-1503-6204")),
......
...@@ -194,24 +194,21 @@ CreateInputsModel <- function(FUN_MOD, ...@@ -194,24 +194,21 @@ CreateInputsModel <- function(FUN_MOD,
if (!("daily" %in% ObjectClass) & !("hourly" %in% ObjectClass)) { if (!("daily" %in% ObjectClass) & !("hourly" %in% ObjectClass)) {
stop("Only daily and hourly time steps can be used in a semi-distributed mode") stop("Only daily and hourly time steps can be used in a semi-distributed mode")
} }
if (!is.matrix(Qupstream) | !is.matrix(LengthHydro) | !is.matrix(BasinAreas)) { if (!is.matrix(Qupstream) | !is.numeric(Qupstream)) {
stop("'Qupstream', 'LengthHydro' and 'BasinAreas' must be matrices of numeric values") stop("'Qupstream' must be a matrice of numeric values")
} }
if (!is.numeric(Qupstream) | !is.numeric(LengthHydro) | !is.numeric(BasinAreas)) { if (!is.vector(LengthHydro) | !is.vector(BasinAreas) | !is.numeric(LengthHydro) | !is.numeric(BasinAreas)) {
stop("'Qupstream', 'LengthHydro' and 'BasinAreas' must be matrices of numeric values") stop("'LengthHydro' and 'BasinAreas' must be vectors of numeric values")
} }
if (ncol(Qupstream) != ncol(LengthHydro)) { if (ncol(Qupstream) != length(LengthHydro)) {
stop("'Qupstream' and 'LengthHydro' must have the same number of columns") stop("'Qupstream' number of columns and 'LengthHydro' length must be equal")
} }
if (ncol(Qupstream)+1 != ncol(BasinAreas)) { if (length(LengthHydro) + 1 != length(BasinAreas)) {
stop("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHydro'") stop("'BasinAreas' must have one more element than 'LengthHydro'")
} }
if (nrow(Qupstream) != LLL) { if (nrow(Qupstream) != LLL) {
stop("'Qupstream' must have same number of rows as 'DatesR' length") stop("'Qupstream' 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")
}
if(any(is.na(Qupstream))) { if(any(is.na(Qupstream))) {
stop("'Qupstream' cannot contain any NA value") stop("'Qupstream' cannot contain any NA value")
} }
......
...@@ -18,7 +18,7 @@ RunModel <- function (InputsModel, RunOptions, Param, FUN_MOD) { ...@@ -18,7 +18,7 @@ RunModel <- function (InputsModel, RunOptions, Param, FUN_MOD) {
AreaTot <- sum(InputsModel$BasinAreas) AreaTot <- sum(InputsModel$BasinAreas)
# propagation time from upstream meshes to outlet # propagation time from upstream meshes to outlet
PT <- InputsModel$LengthHydro[1, ] / Param[length(Param)] / TimeStep PT <- InputsModel$LengthHydro / Param[length(Param)] / TimeStep
HUTRANS <- rbind(1 - (PT - floor(PT)), PT - floor(PT)) HUTRANS <- rbind(1 - (PT - floor(PT)), PT - floor(PT))
NbUpBasins <- length(InputsModel$LengthHydro) NbUpBasins <- length(InputsModel$LengthHydro)
......
...@@ -3,7 +3,7 @@ context("RunModel_LAG") ...@@ -3,7 +3,7 @@ context("RunModel_LAG")
data(L0123001) data(L0123001)
test_that("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHydro'", { test_that("'BasinAreas' must have one more element than 'LengthHydro'", {
expect_error( expect_error(
InputsModel <- CreateInputsModel( InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J, FUN_MOD = RunModel_GR4J,
...@@ -11,14 +11,14 @@ test_that("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHy ...@@ -11,14 +11,14 @@ test_that("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHy
Precip = BasinObs$P, Precip = BasinObs$P,
PotEvap = BasinObs$E, PotEvap = BasinObs$E,
Qupstream = matrix(BasinObs$Qmm, ncol = 1), Qupstream = matrix(BasinObs$Qmm, ncol = 1),
LengthHydro = matrix(c(1), nrow = 1), LengthHydro = 1,
BasinAreas = matrix(c(1), nrow = 1) BasinAreas = 1
), ),
regexp = "'BasinAreas' must have one column more than 'Qupstream' and 'LengthHydro'" regexp = "'BasinAreas' must have one more element than 'LengthHydro'"
) )
}) })
test_that("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHydro'", { test_that("'Qupstream' cannot contain any NA value", {
expect_error( expect_error(
InputsModel <- CreateInputsModel( InputsModel <- CreateInputsModel(
FUN_MOD = RunModel_GR4J, FUN_MOD = RunModel_GR4J,
...@@ -26,8 +26,8 @@ test_that("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHy ...@@ -26,8 +26,8 @@ test_that("'BasinAreas' must have one column more than 'Qupstream' and 'LengthHy
Precip = BasinObs$P, Precip = BasinObs$P,
PotEvap = BasinObs$E, PotEvap = BasinObs$E,
Qupstream = matrix(BasinObs$Qmm, ncol = 1), Qupstream = matrix(BasinObs$Qmm, ncol = 1),
LengthHydro = matrix(c(1), nrow = 1), LengthHydro = 1,
BasinAreas = matrix(c(1, 2), nrow = 1) BasinAreas = c(1, 2)
), ),
regexp = "'Qupstream' cannot contain any NA value" regexp = "'Qupstream' cannot contain any NA value"
) )
...@@ -42,10 +42,8 @@ InputsModel <- CreateInputsModel( ...@@ -42,10 +42,8 @@ InputsModel <- CreateInputsModel(
Precip = BasinObs$P, Precip = BasinObs$P,
PotEvap = BasinObs$E, PotEvap = BasinObs$E,
Qupstream = matrix(Qupstream, ncol = 1), Qupstream = matrix(Qupstream, ncol = 1),
LengthHydro = matrix(c(1000), nrow = 1), LengthHydro = 1000,
BasinAreas = matrix(c( BasinAreas = c(BasinInfo$BasinArea * 2, BasinInfo$BasinArea)
BasinInfo$BasinArea * 2, BasinInfo$BasinArea
), nrow = 1)
) )
Ind_Run <- seq(which(format(BasinObs$DatesR, format = "%Y-%m-%d") == "1990-01-01"), Ind_Run <- seq(which(format(BasinObs$DatesR, format = "%Y-%m-%d") == "1990-01-01"),
...@@ -64,15 +62,15 @@ OutputsGR4JOnly <- ...@@ -64,15 +62,15 @@ OutputsGR4JOnly <-
test_that("Upstream basin with nil area should return same Qdown as GR4J alone", { test_that("Upstream basin with nil area should return same Qdown as GR4J alone", {
UpstBasinArea = InputsModel$BasinAreas[1, 1] UpstBasinArea = InputsModel$BasinAreas[1]
InputsModel$BasinAreas[1, 1] <<- 0 InputsModel$BasinAreas[1] <<- 0
OutputsSD <- OutputsSD <-
RunModel(InputsModel, RunModel(InputsModel,
RunOptions, RunOptions,
Param = c(Param, 1), Param = c(Param, 1),
FUN_MOD = RunModel_GR4J) FUN_MOD = RunModel_GR4J)
expect_equal(OutputsGR4JOnly$Qsim, OutputsSD$Qsim) expect_equal(OutputsGR4JOnly$Qsim, OutputsSD$Qsim)
InputsModel$BasinAreas[1, 1] <<- UpstBasinArea InputsModel$BasinAreas[1] <<- UpstBasinArea
}) })
test_that( test_that(
...@@ -84,8 +82,8 @@ test_that( ...@@ -84,8 +82,8 @@ test_that(
Precip = BasinObs$P, Precip = BasinObs$P,
PotEvap = BasinObs$E, PotEvap = BasinObs$E,
Qupstream = matrix(Qupstream, ncol = 1), Qupstream = matrix(Qupstream, ncol = 1),
LengthHydro = matrix(c(0), nrow = 1), LengthHydro = 0,
BasinAreas = matrix(c(BasinInfo$BasinArea, 0), nrow = 1) BasinAreas = c(BasinInfo$BasinArea, 0)
) )
OutputsSD <- OutputsSD <-
RunModel(InputsModelZeroDown, RunModel(InputsModelZeroDown,
......
Markdown is supported
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