CreateInputsCrit.R

CreateInputsCrit <- function(FUN_CRIT,
                             InputsModel,
                             RunOptions,
                             Qobs,              # deprecated
                             obs,
                             varObs = "Q",
                             BoolCrit = NULL,
                             transfo = "",
                             weights = NULL,
                             Ind_zeroes = NULL, # deprecated
                             epsilon = NULL,
                             warnings = TRUE,
                             verbose = TRUE) {
  
  
  ObjectClass <- NULL
  
  FUN_CRIT <- match.fun(FUN_CRIT)
  
  ## ---------- 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'")
  }
  
  
  ## length of index of period to be used for the model run
  LLL <- length(InputsModel$DatesR[RunOptions$IndPeriod_Run])
  
  
  ## check 'obs' and definition of idLayer
  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", LLL), call. = FALSE)
  }
  if (!is.list(obs)) {
    idLayer <- list(1L)
    obs <- list(obs)
  } else {
    idLayer <- lapply(obs, function(i) {
        if (is.list(i)) {
          length(i)
        } else {
          1L
        }
      })
    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,
                   idLayer    = idLayer,
                   transfo    = transfo,
                   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 'varObs' + 'RunOptions'
  if ("Q" %in% varObs & !inherits(RunOptions, "GR")) {
    stop("'varObs' cannot contain Q if a GR rainfall-runoff model is not used")
  }
  if (any(c("SCA", "SWE") %in% varObs) & !inherits(RunOptions, "CemaNeige")) {
    stop("'varObs' cannot contain SCA or SWE if CemaNeige is not used")
  }
  if ("SCA" %in% varObs & inherits(RunOptions, "CemaNeige") & !"Gratio"   %in% RunOptions$Outputs_Sim) {
    stop("'Gratio' is missing in 'Outputs_Sim' of 'RunOptions', which is necessary to output SCA with CemaNeige")
  }
  if ("SWE" %in% varObs & inherits(RunOptions, "CemaNeige") & !"SnowPack" %in% RunOptions$Outputs_Sim) {
    stop("'SnowPack' is missing in 'Outputs_Sim' of 'RunOptions', which is necessary to output SWE with CemaNeige")
  }

  
  ## 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'")
  }
  
  
  ## 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")
  }

  
  ## ---------- reformat
  
  ## 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")
  msgVarObs <- "'varObs' must be a (list of) character vector(s) and one of %s"
  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"
  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'", call. = FALSE)
    }
    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", call. = FALSE)
    }
    
    ## 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", LLL), call. = FALSE)
    }
    
    ## 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", call. = FALSE)
    }
    if (length(iListArgs2$BoolCrit) != LLL) {
      stop("'BoolCrit' and 'InputsModel' series must have the same length", call. = FALSE)
    }
    
    ## check 'varObs'
    if (!is.vector(iListArgs2$varObs) | length(iListArgs2$varObs) != 1 | !is.character(iListArgs2$varObs) | !all(iListArgs2$varObs %in% inVarObs)) {
      stop(msgVarObs, call. = FALSE)
    }
    
    ## 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")
    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)
    }
    
    ## 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)", call. = FALSE)
      }
    }
    
    ## 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)", call. = FALSE)
      }
    } 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,
                        idLayer = iListArgs2$idLayer,
                        transfo    = iListArgs2$transfo,
                        epsilon    = iListArgs2$epsilon,
                        weights    = iListArgs2$weights)
    class(iInputsCrit) <- c("Single", "InputsCrit", ObjectClass)
    return(iInputsCrit)
    
  })
  names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
  
  
  listVarObs <- sapply(InputsCrit, FUN = "[[", "varObs")
  inCnVarObs <- c("SCA", "SWE")
  if (!"ZLayers" %in% names(InputsModel)) {
    if(any(listVarObs %in% inCnVarObs)) {
      stop(sprintf("'varOBS' can not be equal to %i if CemaNeige is not used",
                   paste(sapply(inCnVarObs, shQuote), collapse = " or ")))
    }
  } else {
    listGroupLayer0 <- sapply(InputsCrit, FUN = "[[", "idLayer")
    listGroupLayer <- rep(listVarObs, times = listGroupLayer0)
    tabGroupLayer  <- as.data.frame(table(listGroupLayer))
    colnames(tabGroupLayer) <- c("varObs", "freq")
    nLayers <- length(InputsModel$ZLayers)
    for (iInCnVarObs in inCnVarObs) {
      if (any(listVarObs %in% iInCnVarObs)) {
        if (tabGroupLayer[tabGroupLayer$varObs %in% iInCnVarObs, "freq"] != nLayers) {
          stop(sprintf("'obs' must contains %i vector(s) about %s", nLayers, iInCnVarObs))
        }
      }
    }
  }
  
  ## define idLayer as an index of the layer to use
  for (iInCnVarObs in unique(listVarObs)) {
    if (iInCnVarObs == "Q") {
      k <- 1
      for (i in which(listVarObs == iInCnVarObs)) {
        InputsCrit[[i]]$idLayer <- NA
        k <- k + 1
      }
    } else {
      aa <- listGroupLayer0[listVarObs == iInCnVarObs]
      bb <- c(0, aa[-length(aa)])
      cc <- lapply(seq_along(aa), function(x) seq_len(aa[x]) + bb[x])
      k <- 1
      for (i in which(listVarObs == iInCnVarObs)) {
        InputsCrit[[i]]$idLayer <- cc[[k]]
        k <- k + 1
      }
    }
  }

  
  ## 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(InputsCrit)
  
}