Utils.R

## =================================================================================
## function to check
## =================================================================================

# .onLoad <- function(libname, pkgname){
#   if (requireNamespace("airGRteaching", quietly = TRUE)) {
#     if (packageVersion("airGRteaching") %in% package_version(c("0.2.0.9", "0.2.2.2", "0.2.3.2"))) {
#       packageStartupMessage("In order to be compatible with the present version of 'airGR', please update your version of the 'airGRteaching' package.")
#     }
#   }
# }



## =================================================================================
## function to manage Fortran outputs
## =================================================================================

.FortranOutputs <- function(GR = NULL, isCN = FALSE) {

  outGR <- NULL
  outCN <- NULL

  if (is.null(GR)) {
    GR <- ""
  }
  if (GR == "GR1A") {
    outGR <- c("PotEvap", "Precip",
               "Qsim")
  } else if (GR == "GR2M") {
    outGR <- c("PotEvap", "Precip", "Prod", "Pn", "Ps",
               "AE",
               "Perc", "PR",
               "Rout", "Exch",
               "Qsim")
  } else if (GR == "GR5H") {
    outGR <- c("PotEvap", "Precip", "Interc", "Prod", "Pn", "Ps",
               "AE", "EI", "ES",
               "Perc", "PR",
               "Q9", "Q1",
               "Rout", "Exch",
               "AExch1", "AExch2",
               "AExch", "QR",
               "QD",
               "Qsim")
  } else if (GR %in% c("GR4J", "GR5J", "GR4H")) {
    outGR <- c("PotEvap", "Precip", "Prod", "Pn", "Ps",
               "AE",
               "Perc", "PR",
               "Q9", "Q1",
               "Rout", "Exch",
               "AExch1", "AExch2",
               "AExch", "QR",
               "QD",
               "Qsim")
  } else if (GR == "GR6J") {
    outGR <- c("PotEvap", "Precip", "Prod", "Pn", "Ps",
               "AE",
               "Perc", "PR",
               "Q9", "Q1",
               "Rout", "Exch",
               "AExch1", "AExch2",
               "AExch", "QR",
               "QRExp", "Exp",
               "QD",
               "Qsim")
  }
  if (isCN) {
    outCN <- c("Pliq", "Psol",
               "SnowPack", "ThermalState", "Gratio",
               "PotMelt", "Melt", "PliqAndMelt", "Temp",
               "Gthreshold", "Glocalmax")
  }

  res <- list(GR = outGR, CN = outCN)

}



## =================================================================================
## functions to extract parts of InputsModel or OutputsModel objects
## =================================================================================

## InputsModel

.ExtractInputsModel <- function(x, i) {
  res <- lapply(x, function(x) {
    if (is.matrix(x)) {
      res0 <- x[i, , drop = FALSE]
    }
    if (is.vector(x) | inherits(x, "POSIXt")) {
      res0 <- x[i]
    }
    if (is.list(x) & !inherits(x, "POSIXt")) {
      if (inherits(x, "OutputsModel")) {
        res0 <- .ExtractOutputsModel(x = x, i = i)
      } else {
        res0 <- .ExtractInputsModel(x = x, i = i)
      }
    }
    return(res0)
  })
  if (!is.null(x$ZLayers)) {
    res$ZLayers <- x$ZLayers
  }
  if (inherits(x, "SD")) {
    res$LengthHydro <- x$LengthHydro
    res$BasinAreas  <- x$BasinAreas
  }
  class(res) <- class(x)
  res
}

'[.InputsModel' <- function(x, i) {
  if (!inherits(x, "InputsModel")) {
    stop("'x' must be of class 'InputsModel'")
  }
  if (is.factor(i)) {
    i <- as.character(i)
  }
  if (is.numeric(i)) {
    .ExtractInputsModel(x, i)
  } else {
    NextMethod()
  }
}


## InputsModel

.ExtractOutputsModel <- function(x, i) {
  res <- lapply(x, function(x) {
    if (is.matrix(x)  && length(dim(x)) == 2L) {
      res0 <- x[i, ]
    }
    if (is.array(x) && length(dim(x)) == 3L) {
      res0 <- x[i, , ]
    }
    if (is.vector(x) | inherits(x, "POSIXt")) {
      res0 <- x[i]
    }
    if (is.list(x) & !inherits(x, "POSIXt")) {
      res0 <- .ExtractOutputsModel(x = x, i = i)
    }
    return(res0)
  })
  if (!is.null(x$StateEnd)) {
    res$StateEnd <- x$StateEnd
  }
  class(res) <- class(x)
  res
}

'[.OutputsModel' <- function(x, i) {
  if (!inherits(x, "OutputsModel")) {
    stop("'x' must be of class 'OutputsModel'")
  }
  if (is.factor(i)) {
    i <- as.character(i)
  }
  if (is.numeric(i)) {
    .ExtractOutputsModel(x, i)
  } else {
    NextMethod()
  }
}