tests/testthat/test-CreateInputsModel.R

In inrae/airGRiwrm: 'airGR' Integrated Water Resource Management

test_that("airGR::CreateInputsModel should work", {
  ## loading catchment data
  data(L0123001)

  ## preparation of InputsModel object
  InputsModel <- airGR::CreateInputsModel(FUN_MOD = RunModel_GR4J, DatesR = BasinObs$DatesR,
                                   Precip = BasinObs$P, PotEvap = BasinObs$E)

  expect_equal(CreateInputsModel(RunModel_GR4J,
                                 DatesR = BasinObs$DatesR,
                                 Precip = BasinObs$P,
                                 PotEvap = BasinObs$E),
               InputsModel)
  expect_equal(CreateInputsModel("RunModel_GR4J",
                                 DatesR = BasinObs$DatesR,
                                 Precip = BasinObs$P,
                                 PotEvap = BasinObs$E),
               InputsModel)
})


l <- setUpCemaNeigeData()

test_that("CemaNeige data should be in InputsModel", {
  InputsModels <- suppressWarnings(
    CreateInputsModel(l$griwrm,
                      DatesR = l$DatesR,
                      Precip = l$Precip,
                      PotEvap = l$PotEvap,
                      TempMean = l$TempMean,
                      ZInputs = l$ZInputs,
                      HypsoData = l$HypsoData)
  )
  l$DatesR <- as.data.frame(l$DatesR)
  lapply(InputsModels, function(IM) {
    lapply(c("DatesR", "Precip", "PotEvap"), function(varName) {
      expect_equal(IM[[varName]], l[[varName]][, 1])
    })
    expect_named(IM$LayerPrecip, paste0("L", seq(1, 5)))
    expect_named(IM$LayerTempMean, paste0("L", seq(1, 5)))
    expect_named(IM$LayerFracSolidPrecip, paste0("L", seq(1, 5)))
  })
})

test_that("downstream sub-catchment area should be positive", {
  l$griwrm$area[3] <- 360
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 TempMean = l$TempMean,
                                 ZInputs = l$ZInputs,
                                 HypsoData = l$HypsoData),
               regexp = "must be greater than the sum of the areas")
})

test_that("handles mix of with and without CemaNeige nodes", {
  l$griwrm[l$griwrm$id == "Down", "model"] <- "RunModel_GR4J"
  l$TempMean <- l$TempMean[, 1:2]
  l$ZInputs <- l$ZInputs[1:2]
  l$TempMean <- l$TempMean[, 1:2]
  l$HypsoData <- l$HypsoData[, 1:2]
  InputsModels <- suppressWarnings(
    CreateInputsModel(l$griwrm,
                      DatesR = l$DatesR,
                      Precip = l$Precip,
                      PotEvap = l$PotEvap,
                      TempMean = l$TempMean,
                      ZInputs = l$ZInputs,
                      HypsoData = l$HypsoData)
  )
  expect_false(inherits(InputsModels$Down, "CemaNeige"))
  expect_null(InputsModels$Down$LayerPrecip)
})

test_that("throws error on wrong column name", {
  colnames(l$Precip)[1] <- "Up0"
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 TempMean = l$TempMean,
                                 ZInputs = l$ZInputs,
                                 HypsoData = l$HypsoData),
               regexp = "column names must be included in.*Up0")
  colnames(l$Precip) <- NULL
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 TempMean = l$TempMean,
                                 ZInputs = l$ZInputs,
                                 HypsoData = l$HypsoData),
               regexp = "must have column names")
})

test_that("throw error on missing column in inputs", {
  l$Precip <- l$Precip[, -1]
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 TempMean = l$TempMean,
                                 ZInputs = l$ZInputs,
                                 HypsoData = l$HypsoData),
               regexp = "Precip is missing")
})

test_that("throw error on wrong number of rows in inputs", {
  l$Precip <- l$Precip[-1, ]
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 TempMean = l$TempMean,
                                 ZInputs = l$ZInputs,
                                 HypsoData = l$HypsoData),
               regexp = "number of rows and the length of 'DatesR' must be equal")
})


test_that("throws error when missing CemaNeige data", {
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap),
               regexp = "'TempMean' is missing")
})

test_that("throws error when missing Qinf on node Direct Injection node", {
  l$griwrm$model[1] <- NA
  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap),
               regexp = "'Qinf' column names must at least contain")

  expect_error(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 Qinf = l$Qobs[, -1]),
               regexp = "'Qinf' column names must at least contain")
})

test_that("must works with node not related to an hydrological model", {
  l$griwrm$model[1] <- NA
  IM <- suppressWarnings(CreateInputsModel(
    l$griwrm,
    DatesR = l$DatesR,
    Precip = l$Precip,
    PotEvap = l$PotEvap,
    Qinf = l$Qobs[, 1, drop = FALSE],
    TempMean = l$TempMean,
    ZInputs = l$ZInputs,
    HypsoData = l$HypsoData
  ))
  expect_equal(IM[[2]]$Qupstream[, "Up1"], l$Qobs[, "Up1"] * l$griwrm[1, "area"] * 1E3)
  expect_equal(colnames(IM[[2]]$Qupstream), c("Up1", "Up2"))
})

test_that("Qinf on hydrological nodes should throw a warning", {
  expect_warning(CreateInputsModel(l$griwrm,
                                 DatesR = l$DatesR,
                                 Precip = l$Precip,
                                 PotEvap = l$PotEvap,
                                 Qinf = l$Qobs,
                                 TempMean = l$TempMean,
                                 ZInputs = l$ZInputs,
                                 HypsoData = l$HypsoData),
               regexp = "columns in 'Qinf' are ignored since they don't match with")
  l$griwrm$model[1] <- NA
  expect_s3_class(suppressWarnings(
    CreateInputsModel(
      l$griwrm,
      DatesR = l$DatesR,
      Precip = l$Precip,
      PotEvap = l$PotEvap,
      Qinf = l$Qobs[,1, drop = F],
      TempMean = l$TempMean,
      ZInputs = l$ZInputs,
      HypsoData = l$HypsoData
    )
  ),
  "GRiwrmInputsModel")
})

# data set up
e <- setupRunModel(runInputsModel = FALSE)
# variables are copied from environment 'e' to the current environment
# https://stackoverflow.com/questions/9965577/r-copy-move-one-environment-to-another
for(x in ls(e)) assign(x, get(x, e))

test_that("Ungauged node should inherits its FUN_MOD from the downstream gauged node", {

  nodes$model[nodes$id == "54032"] <- "Ungauged"
  griwrmV05 <- CreateGRiwrm(nodes)
  IM <- suppressWarnings(
    CreateInputsModel(griwrmV05, DatesR, Precip, PotEvap)
  )
  expect_equal(IM[["54032"]]$FUN_MOD, "RunModel_GR4J")
})

test_that("Network with Diversion works", {
  n_div <- rbind(
    data.frame(id = "54029",
               down = "54002",
               length = 20,
               model = "Diversion",
               area = NA),
    nodes
  )
  g <- CreateGRiwrm(n_div)
  Qinf = matrix(-1, nrow = length(DatesR), ncol = 1)
  colnames(Qinf) = "54029"
  IM <- suppressWarnings(
    CreateInputsModel(g, DatesR, Precip, PotEvap, Qinf)
  )
  expect_equal(IM[["54032"]]$UpstreamNodes, c("54029", "54001"))
  expect_equal(IM[["54032"]]$UpstreamVarQ , c("54029" = "Qsim_m3", "54001" = "Qsim_m3"))
  expect_equal(IM[["54002"]]$UpstreamNodes, "54029")
  expect_equal(IM[["54002"]]$UpstreamIsModeled  , c("54029" = TRUE))
  expect_equal(IM[["54002"]]$UpstreamVarQ , c("54029" = "Qdiv_m3"))
  expect_equivalent(IM$`54029`$Qmin, matrix(0, nrow = length(DatesR), ncol = 1))
})

test_that("Diversion node: checks about 'Qmin'", {
  n_div <- rbind(nodes,
                 data.frame(id = "54029", down = "54002", length = 50, area = NA, model = "Diversion"))
  g <- CreateGRiwrm(n_div)
  Qinf = matrix(-1, nrow = length(DatesR), ncol = 1)
  colnames(Qinf) = "54029"
  expect_warning(CreateInputsModel(g, DatesR, Precip, PotEvap, Qinf = Qinf),
                 regexp = "Zero values")
  Qmin <- -Qinf
  IM <- CreateInputsModel(g, DatesR, Precip, PotEvap, Qinf = Qinf, Qmin = Qmin)
  expect_equivalent(IM$`54029`$Qmin, Qmin)
  QminNA <- Qmin
  QminNA[1] <- NA
  expect_error(CreateInputsModel(g, DatesR, Precip, PotEvap, Qinf = Qinf, Qmin = QminNA),
               regexp = "NA")
  QminBadCol <- Qmin
  colnames(QminBadCol) = "54002"
  expect_error(CreateInputsModel(g, DatesR, Precip, PotEvap, Qinf = Qinf, Qmin = QminBadCol),
               regexp = "columns that does not match with IDs of Diversion nodes")
})

test_that("Node with upstream nodes having area = NA should return correct BasinsAreas", {
  nodes <- loadSevernNodes()
  # Reduce the network
  nodes <- nodes[nodes$id %in% c("54095", "54001"), ]
  nodes$down[nodes$id == "54001"] <- NA
  nodes$length[nodes$id == "54001"] <- NA
  # Insert a dam downstream the location the gauging station 54095
  # The dam is a direct injection node
  nodes$down[nodes$id == "54095"] <- "Dam"
  nodes$length[nodes$id == "54095"] <- 0
  nodes <- rbind(nodes,
                 data.frame(id = "Dam",
                            down = "54001",
                            length = 42,
                            area = NA,
                            model = "RunModel_Reservoir"))
  g <- CreateGRiwrm(nodes)
  Qinf <- data.frame(
    Dam = rep(0,11536)
  )
  e <- setupRunModel(griwrm = g, runInputsModel = FALSE, Qinf = Qinf)
  for (x in ls(e)) assign(x, get(x, e))
  InputsModel <-
    suppressWarnings(CreateInputsModel(g, DatesR, Precip, PotEvap, Qinf = Qinf))
  expect_equal(sum(InputsModel$`54001`$BasinAreas),
               g$area[g$id == "54001"])
})

test_that("Use of Qinf for Qrelease should raise a warning",  {
  g <- CreateGRiwrm(n_rsrvr)
  e <- setupRunModel(griwrm = g, runInputsModel = FALSE)
  for (x in ls(e)) assign(x, get(x, e))
  expect_warning(CreateInputsModel(griwrm, DatesR, Precip, PotEvap,
                                   TempMean = TempMean,
                                   Qinf = Qinf_rsrvr))
})