R/UtilsCalibOptions.R

In airGR: Suite of GR Hydrological Models for Precipitation-Runoff Modelling

.FunTransfo <- function(FeatFUN_MOD) {

  IsHyst <- FeatFUN_MOD$IsHyst
  IsSD <- FeatFUN_MOD$IsSD

  ## set FUN_GR
  if (FeatFUN_MOD$NameFunMod == "Cemaneige") {
    if (IsHyst) {
      FUN_GR <- TransfoParam_CemaNeigeHyst
    } else {
      FUN_GR <- TransfoParam_CemaNeige
    }
  } else {
    # fatal error if the TransfoParam function does not exist
    FUN_GR <- match.fun(sprintf("TransfoParam_%s", FeatFUN_MOD$CodeModHydro))
  }

  ## set FUN_SNOW
  if ("CemaNeige" %in% FeatFUN_MOD$Class) {
    if (IsHyst) {
      FUN_SNOW <- TransfoParam_CemaNeigeHyst
    } else {
      FUN_SNOW <- TransfoParam_CemaNeige
    }
  }

  ## set FUN_LAG
  if (IsSD) {
    FUN_LAG <- TransfoParam_Lag
  }

    ## set FUN_TRANSFO
  if (! "CemaNeige" %in% FeatFUN_MOD$Class) {
    if (!IsSD) {
      FUN_TRANSFO <- FUN_GR
    } else {
      FUN_TRANSFO <- function(ParamIn, Direction) {
        Bool <- is.matrix(ParamIn)
        if (!Bool) {
          ParamIn <- rbind(ParamIn)
        }
        ParamOut <- NA * ParamIn
        NParam   <- ncol(ParamIn)
        ParamOut[, 2:NParam] <- FUN_GR(ParamIn[, 2:NParam], Direction)
        ParamOut[, 1       ] <- FUN_LAG(as.matrix(ParamIn[, 1]), Direction)
        if (!Bool) {
          ParamOut <- ParamOut[1, ]
        }
        return(ParamOut)
      }
    }
  } else {
    if (IsHyst & !IsSD) {
      FUN_TRANSFO <- function(ParamIn, Direction) {
        Bool <- is.matrix(ParamIn)
        if (!Bool) {
          ParamIn <- rbind(ParamIn)
        }
        ParamOut <- NA * ParamIn
        NParam   <- ncol(ParamIn)
        ParamOut[, 1:(NParam - 4)     ] <- FUN_GR(ParamIn[, 1:(NParam - 4)], Direction)
        ParamOut[, (NParam - 3):NParam] <- FUN_SNOW(ParamIn[, (NParam - 3):NParam], Direction)
        if (!Bool) {
          ParamOut <- ParamOut[1, ]
        }
        return(ParamOut)
      }
    }
    if (!IsHyst & !IsSD) {
      FUN_TRANSFO <- function(ParamIn, Direction) {
        Bool <- is.matrix(ParamIn)
        if (!Bool) {
          ParamIn <- rbind(ParamIn)
        }
        ParamOut <- NA * ParamIn
        NParam   <- ncol(ParamIn)
        if (NParam <= 3) {
          ParamOut[, 1:(NParam - 2)] <- FUN_GR(cbind(ParamIn[, 1:(NParam - 2)]), Direction)
        } else {
          ParamOut[, 1:(NParam - 2)] <- FUN_GR(ParamIn[, 1:(NParam - 2)], Direction)
        }
        ParamOut[, (NParam - 1):NParam] <- FUN_SNOW(ParamIn[, (NParam - 1):NParam], Direction)
        if (!Bool) {
          ParamOut <- ParamOut[1, ]
        }
        return(ParamOut)
      }
    }
    if (IsHyst & IsSD) {
      FUN_TRANSFO <- function(ParamIn, Direction) {
        Bool <- is.matrix(ParamIn)
        if (!Bool) {
          ParamIn <- rbind(ParamIn)
        }
        ParamOut <- NA * ParamIn
        NParam   <- ncol(ParamIn)
        ParamOut[, 2:(NParam - 4)     ] <- FUN_GR(ParamIn[, 2:(NParam - 4)], Direction)
        ParamOut[, (NParam - 3):NParam] <- FUN_SNOW(ParamIn[, (NParam - 3):NParam], Direction)
        ParamOut[, 1                  ] <- FUN_LAG(as.matrix(ParamIn[, 1]), Direction)
        if (!Bool) {
          ParamOut <- ParamOut[1, ]
        }
        return(ParamOut)
      }
    }
    if (!IsHyst & IsSD) {
      FUN_TRANSFO <- function(ParamIn, Direction) {
        Bool <- is.matrix(ParamIn)
        if (!Bool) {
          ParamIn <- rbind(ParamIn)
        }
        ParamOut <- NA * ParamIn
        NParam   <- ncol(ParamIn)
        if (NParam <= 3) {
          ParamOut[, 2:(NParam - 2)] <- FUN_GR(cbind(ParamIn[, 2:(NParam - 2)]), Direction)
        } else {
          ParamOut[, 2:(NParam - 2)] <- FUN_GR(ParamIn[, 2:(NParam - 2)],  Direction)
        }
        ParamOut[, (NParam - 1):NParam] <- FUN_SNOW(ParamIn[, (NParam - 1):NParam], Direction)
        ParamOut[, 1                  ] <- FUN_LAG(as.matrix(ParamIn[, 1]), Direction)
        if (!Bool) {
          ParamOut <- ParamOut[1, ]
        }
        return(ParamOut)
      }
    }
  }
  if (is.null(FUN_TRANSFO)) {
    stop("'FUN_TRANSFO' was not found")
  }
  return(FUN_TRANSFO)
}