CreateInputsCrit.R

CreateInputsCrit <- function(FUN_CRIT,
                             InputsModel,
                             RunOptions,
                             Qobs,
                             obs,
                             varObs = "Q",
                             BoolCrit = NULL,
                             transfo = "",
                             # groupLayer,
                             weights = NULL,
                             Ind_zeroes = NULL,
                             epsilon = NULL,
                             warnings = TRUE,
                             verbose = TRUE) {
  
  
  ObjectClass <- NULL
  
  ## ---------- check arguments
  
  if (!missing(Qobs)) {
    if (missing(obs)) {
      if (warnings) {
        warning("argument 'Qobs' is deprecated. Please use 'obs' and 'varObs' instead")
      }
      obs <- Qobs
      # varObs <- "Qobs"
    } else {
      warning("argument 'Qobs' is deprecated. The values set in 'obs' will be used instead")
    }
  }
  if (!missing(Ind_zeroes) & warnings) {
    warning("Deprecated 'Ind_zeroes' argument")
  }
  if (!missing(verbose)) {
    warning("Deprecated 'verbose' argument. Use 'warnings', instead")
  }
  
  
  ## check 'InputsModel'
  if (!inherits(InputsModel, "InputsModel")) {
    stop("'InputsModel' must be of class 'InputsModel' \n")
    return(NULL)
  }
  
  
  ## length of index of period to be used for the model run
  LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
  
  
  ## check 'obs'
  vecObs <- unlist(obs)
  if (length(vecObs) %% LLL != 0 | !is.numeric(vecObs)) {
    stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i \n", LLL), call. = FALSE)
  }
  if (!is.list(obs)) {
    obs <- list(obs)
  } else {
    obs <- lapply(obs, function(x) rowMeans(as.data.frame(x)))
  }
  
  
  ## create list of arguments
  listArgs <- list(FUN_CRIT   = FUN_CRIT,
                   obs        = obs,
                   varObs     = varObs,
                   BoolCrit   = BoolCrit,
                   transfo    = transfo,
                   # groupLayer = groupLayer,
                   weights    = weights,
                   epsilon    = epsilon)
  
  
  ## check lists lengths
  for (iArgs in names(listArgs)) {
    if (iArgs %in% c("weights", "BoolCrit", "epsilon")) {
      if (any(is.null(listArgs[[iArgs]]))) {
        listArgs[[iArgs]] <- lapply(seq_along(listArgs$FUN_CRIT), function(x) NULL)
      }
    }
    if (!is.list(listArgs[[iArgs]])) {
      listArgs[[iArgs]] <- list(listArgs[[iArgs]])
    }
  }
  
  ## check 'varObs'
  if (missing(varObs)) {
    listArgs$varObs <- as.list(rep("Q", times = length(listArgs$obs)))
    # if (warnings) {
    #   warning("'varObs' automatically set to \"Q\"")
    # }
  }
  
  ## check 'transfo'
  if (missing(transfo)) {
    listArgs$transfo <- as.list(rep("", times = length(listArgs$obs)))
    # if (warnings) {
    #   warning("'transfo' automatically set to \"\"")
    # }
  }  
  
  ## check length of each args
  if (length(unique(sapply(listArgs, FUN = length))) != 1) {
    stopListArgs <- paste(sapply(names(listArgs), shQuote), collapse = ", ")
    stop(sprintf("arguments %s must have the same length", stopListArgs))
  }
  
  
  ## check 'RunOptions'
  if (!inherits(RunOptions , "RunOptions")) {
    stop("'RunOptions' must be of class 'RunOptions' \n")
    return(NULL)
  }
  
  
  ## check 'weights'
  if (length(listArgs$weights) > 1 & sum(unlist(listArgs$weights)) == 0 & !any(sapply(listArgs$weights, is.null))) {
    stop("sum of 'weights' cannot be equal to zero \n")
  }
  
  
  ## reformat list of arguments
  listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i))
  
  
  ## preparation of warning messages
  inVarObs  <- c("Q", "SCA", "SWE", "SD")
  msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s \n"
  msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ", "))
  inTransfo  <- c("", "sqrt", "log", "inv", "sort")
  msgTransfo <- "'transfo' must be a (list of) character vector(s) and one of %s \n"
  msgTransfo <- sprintf(msgTransfo, paste(sapply(inTransfo, shQuote), collapse = ", "))
  
  
  ## ---------- loop on the list of inputs
  
  InputsCrit <- lapply(listArgs2, function(iListArgs2) {
    
    ## check 'FUN_CRIT'
    if (!(identical(iListArgs2$FUN_CRIT, ErrorCrit_NSE ) | identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE ) |
          identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE2) | identical(iListArgs2$FUN_CRIT, ErrorCrit_RMSE))) {
      stop("incorrect 'FUN_CRIT' for use in 'CreateInputsCrit' \n", call. = FALSE)
      return(NULL)
    }
    if (identical(iListArgs2$FUN_CRIT, ErrorCrit_RMSE) & length(listArgs$weights) > 1 & all(!is.null(unlist(listArgs$weights)))) {
      stop("calculating a composite criterion with the RMSE is not allowed since RMSE is not an adimensional measure \n", call. = FALSE)
      return(NULL)
    }
    
    ## check 'obs'
    if (!is.vector(iListArgs2$obs) | length(iListArgs2$obs) != LLL | !is.numeric(iListArgs2$obs)) {
      stop(sprintf("'obs' must be a (list of) vector(s) of numeric values of length %i \n", LLL), call. = FALSE)
      return(NULL)
    }
    
    ## check 'BoolCrit'
    if (is.null(iListArgs2$BoolCrit)) {
      iListArgs2$BoolCrit <- rep(TRUE, length(iListArgs2$obs))
    }
    if (!is.logical(iListArgs2$BoolCrit)) {
      stop("'BoolCrit' must be a (list of) vector(s) of boolean \n", call. = FALSE)
      return(NULL)
    }
    if (length(iListArgs2$BoolCrit) != LLL) {
      stop("'BoolCrit' and 'InputsModel' series must have the same length \n", call. = FALSE)
      return(NULL)
    }
    
    ## check 'varObs'
    if (!is.vector(iListArgs2$varObs) | length(iListArgs2$varObs) != 1 | !is.character(iListArgs2$varObs) | !all(iListArgs2$varObs %in% inVarObs)) {
      stop(msgVarObs, call. = FALSE)
      return(NULL)
    }
    
    ## check 'varObs' + 'obs'
    if (any(iListArgs2$varObs %in% "SCA")) {
      idSCA <- which(iListArgs2$varObs == "SCA")
      vecSCA <- unlist(iListArgs2$obs[idSCA])
      if (min(vecSCA, na.rm = TRUE) < 0 | max(vecSCA, na.rm = TRUE) > 1) {
        stop("'obs' outside [0,1] for \"SCA\" for 'varObs'", call. = FALSE)
      }
    } 
    inPosVarObs <- c("Q", "SWE", "SD")
    if (any(iListArgs2$varObs %in% inPosVarObs)) {
      idQSS <- which(iListArgs2$varObs %in% inPosVarObs)
      vecQSS <- unlist(iListArgs2$obs[idQSS])
      if (min(vecQSS, na.rm = TRUE) < 0) {
        stop(sprintf("'obs' outside [0,Inf[ for \"%s\" for 'varObs'", iListArgs2$varObs), call. = FALSE)
      }
    }
    
    
    ## check 'transfo'
    if (is.null(iListArgs2$transfo) | !is.vector(iListArgs2$transfo) | length(iListArgs2$transfo) != 1 | !is.character(iListArgs2$transfo) | !all(iListArgs2$transfo %in% inTransfo)) {
      stop(msgTransfo, call. = FALSE)
      return(NULL)
    }
    
    ## check 'weights'
    if (!is.null(iListArgs2$weights)) {
      if (!is.vector(iListArgs2$weights) | length(iListArgs2$weights) != 1 | !is.numeric(iListArgs2$weights) | any(iListArgs2$weights < 0)) {
        stop("'weights' must be a single (list of) positive or equal to zero value(s) \n", call. = FALSE)
        return(NULL)
      }
    }
    
    ## check 'epsilon'
    if (!is.null(iListArgs2$epsilon)) {
      if (!is.vector(iListArgs2$epsilon) | length(iListArgs2$epsilon) != 1 | !is.numeric(iListArgs2$epsilon) | any(iListArgs2$epsilon <= 0)) {
        stop("'epsilon' must be a single (list of) positive value(s) \n", call. = FALSE)
        return(NULL)
      }
    } else if (iListArgs2$transfo %in% c("log", "inv") & any(iListArgs2$obs %in% 0) & warnings) {
      warning("zeroes detected in obs: the corresponding time-steps will be excluded by the 'ErrorCrit*' functions if the epsilon agrument = NULL", call. = FALSE)
    }
    
    ## check 'transfo' + 'FUN_CRIT'
    if (iListArgs2$transfo == "log" & warnings) {
      warn_log_kge <- "we do not advise using the %s with a log transformation on obs (see the details part in the 'CreateInputsCrit' help)"
      if (identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE)) {
        warning(sprintf(warn_log_kge, "KGE"), call. = FALSE)
      }
      if (identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE2)) {
        warning(sprintf(warn_log_kge, "KGE'"), call. = FALSE)
      }
    }
    
    ## Create InputsCrit
    iInputsCrit <- list(FUN_CRIT   = iListArgs2$FUN_CRIT,
                        obs        = iListArgs2$obs,
                        varObs     = iListArgs2$varObs,
                        BoolCrit   = iListArgs2$BoolCrit,
                        # groupLayer = iListArgs2$groupLayer,
                        transfo    = iListArgs2$transfo,
                        epsilon    = iListArgs2$epsilon,
                        weights    = iListArgs2$weights)
    class(iInputsCrit) <- c("Single", "InputsCrit", ObjectClass)
    return(iInputsCrit)
    
  })
  names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
  
  # if only one criterion --> not a list of InputsCrit but directly an InputsCrit
  if (length(InputsCrit) < 2) {
    InputsCrit <- InputsCrit[[1L]]
    InputsCrit["weights"] <- list(weights = NULL)
  } else {
    if (any(sapply(listArgs$weights, is.null))) {
      for (iListArgs in InputsCrit) {
        iListArgs$weights <- NULL
      }
      class(InputsCrit) <- c("Multi", "InputsCrit", ObjectClass)
    } else {
      class(InputsCrit) <- c("Compo", "InputsCrit", ObjectClass)
    }
    combInputsCrit <- combn(x = length(InputsCrit), m = 2)
    apply(combInputsCrit, MARGIN = 2, function(i) {
      equalInputsCrit <- identical(InputsCrit[[i[1]]], InputsCrit[[i[2]]])
      if(equalInputsCrit) {
        warning(sprintf("Elements %i and %i of the criteria list are identical. This might not be necessary", i[1], i[2]), call. = FALSE)
      }
      return(NULL)
    })
  }
  
  return(InputsCrit)
  
}