Commit 755717fc authored by Dorchies David's avatar Dorchies David
Browse files

feat: add ErrorCrit_GAPX

- Modified CreateInputsCrit for handling parameters

Refs #111
parent 4e33703e
...@@ -15,3 +15,8 @@ Param_Sets_GR4J RunOptions_Val ...@@ -15,3 +15,8 @@ Param_Sets_GR4J RunOptions_Val
Param_Sets_GR4J OutputsModel_Val Param_Sets_GR4J OutputsModel_Val
RunModel_Lag OutputsModelDown RunModel_Lag OutputsModelDown
SeriesAggreg SimulatedMonthlyRegime SeriesAggreg SimulatedMonthlyRegime
* InputsCrit$FUN_CRIT
* InputsCritSingle$FUN_CRIT
* InputsCritCompo
* InputsCritMulti
Param_Sets_GR4J InputsCrit_Val$FUN_CRIT
...@@ -24,6 +24,7 @@ S3method(SeriesAggreg, OutputsModel) ...@@ -24,6 +24,7 @@ S3method(SeriesAggreg, OutputsModel)
export(Calibration) export(Calibration)
export(Calibration_Michel) export(Calibration_Michel)
export(CreateCalibOptions) export(CreateCalibOptions)
export(CreateErrorCrit_GAPX)
export(CreateIniStates) export(CreateIniStates)
export(CreateInputsCrit) export(CreateInputsCrit)
export(CreateInputsModel) export(CreateInputsModel)
......
CreateErrorCrit_GAPX <- function(FUN_TRANSFO) {
FUN_CRIT <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
## Arguments check
if (!inherits(OutputsModel, "OutputsModel")) {
stop("'OutputsModel' must be of class 'OutputsModel'")
}
OutputsModel$ParamT <- FUN_TRANSFO(OutputsModel$Param, "RT")
EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "GAPX", OutputsModel = OutputsModel, warnings = warnings)
CritValue <- NA
if (EC$CritCompute) {
ParamApr <- EC$VarObs[!EC$TS_ignore]
ParamOpt <- EC$VarSim[!EC$TS_ignore]
## ErrorCrit
Crit <- 1 - sum(((ParamApr - ParamOpt) / 20)^2)^0.5
if (is.numeric(Crit) & is.finite(Crit)) {
CritValue <- Crit
}
## Verbose
if (verbose) {
message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue))
}
}
## Output
OutputsCrit <- list(CritValue = CritValue,
CritName = EC$CritName,
CritBestValue = EC$CritBestValue,
Multiplier = EC$Multiplier,
Ind_notcomputed = EC$Ind_TS_ignore)
class(OutputsCrit) <- c("GAPX", "ErrorCrit")
return(OutputsCrit)
}
class(FUN_CRIT) <- c("FUN_CRIT", class(FUN_CRIT))
return(FUN_CRIT)
}
...@@ -48,9 +48,22 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -48,9 +48,22 @@ CreateInputsCrit <- function(FUN_CRIT,
## check 'Obs' and definition of idLayer ## check 'Obs' and definition of idLayer
vecObs <- unlist(Obs) if (!is.numeric(unlist(Obs))) {
if (length(vecObs) %% LLL != 0 | !is.numeric(vecObs)) { stop("'Obs' must be a (list of) vector(s) of numeric values")
stop(sprintf("'Obs' must be a (list of) vector(s) of numeric values of length %i", LLL), call. = FALSE) }
Obs2 <- Obs
if ("ParamT" %in% VarObs) {
if (is.list(Obs2)) {
Obs2[[which(VarObs == "ParamT")]] <- NULL
} else {
Obs2 <- NULL
}
}
if (!is.null(Obs2)) {
vecObs <- unlist(Obs2)
if (length(vecObs) %% LLL != 0) {
stop(sprintf("'Obs' must be a (list of) vector(s) of numeric values of length %i", LLL), call. = FALSE)
}
} }
if (!is.list(Obs)) { if (!is.list(Obs)) {
idLayer <- list(1L) idLayer <- list(1L)
...@@ -154,7 +167,7 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -154,7 +167,7 @@ CreateInputsCrit <- function(FUN_CRIT,
listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i)) listArgs2 <- lapply(seq_along(listArgs$FUN_CRIT), function(i) lapply(listArgs, "[[", i))
## preparation of warning messages ## preparation of warning messages
inVarObs <- c("Q", "SCA", "SWE") inVarObs <- c("Q", "SCA", "SWE", "ParamT")
msgVarObs <- "'VarObs' must be a (list of) character vector(s) and one of %s" msgVarObs <- "'VarObs' must be a (list of) character vector(s) and one of %s"
msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ", ")) msgVarObs <- sprintf(msgVarObs, paste(sapply(inVarObs, shQuote), collapse = ", "))
inTransfo <- c("", "sqrt", "log", "inv", "sort", "boxcox") # pow is not checked by inTransfo, but appears in the warning message and checkef after (see ## check 'transfo') inTransfo <- c("", "sqrt", "log", "inv", "sort", "boxcox") # pow is not checked by inTransfo, but appears in the warning message and checkef after (see ## check 'transfo')
...@@ -166,9 +179,11 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -166,9 +179,11 @@ CreateInputsCrit <- function(FUN_CRIT,
InputsCrit <- lapply(listArgs2, function(iListArgs2) { InputsCrit <- lapply(listArgs2, function(iListArgs2) {
## define FUN_CRIT as a character string
iListArgs2$FUN_CRIT <- match.fun(iListArgs2$FUN_CRIT)
## check 'FUN_CRIT' ## check 'FUN_CRIT'
if (!(identical(iListArgs2$FUN_CRIT, ErrorCrit_NSE ) | identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE ) | if (!all(class(iListArgs2$FUN_CRIT) == c("FUN_CRIT", "function"))) {
identical(iListArgs2$FUN_CRIT, ErrorCrit_KGE2) | identical(iListArgs2$FUN_CRIT, ErrorCrit_RMSE))) {
stop("incorrect 'FUN_CRIT' for use in 'CreateInputsCrit'", call. = FALSE) 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)))) { if (identical(iListArgs2$FUN_CRIT, ErrorCrit_RMSE) & length(listArgs$Weights) > 1 & all(!is.null(unlist(listArgs$Weights)))) {
...@@ -176,7 +191,14 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -176,7 +191,14 @@ CreateInputsCrit <- function(FUN_CRIT,
} }
## check 'Obs' ## check 'Obs'
if (!is.vector(iListArgs2$Obs) | length(iListArgs2$Obs) != LLL | !is.numeric(iListArgs2$Obs)) { if (iListArgs2$VarObs == "ParamT") {
# Parameter for regularisation
L2 <- RunOptions$FeatFUN_MOD$NbParam
} else {
# Observation time series
L2 <- LLL
}
if (!is.vector(iListArgs2$Obs) | length(iListArgs2$Obs) != L2 | !is.numeric(iListArgs2$Obs)) {
stop(sprintf("'Obs' must be a (list of) vector(s) of numeric values of length %i", LLL), call. = FALSE) stop(sprintf("'Obs' must be a (list of) vector(s) of numeric values of length %i", LLL), call. = FALSE)
} }
...@@ -187,7 +209,7 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -187,7 +209,7 @@ CreateInputsCrit <- function(FUN_CRIT,
if (!is.logical(iListArgs2$BoolCrit)) { if (!is.logical(iListArgs2$BoolCrit)) {
stop("'BoolCrit' must be a (list of) vector(s) of boolean", call. = FALSE) stop("'BoolCrit' must be a (list of) vector(s) of boolean", call. = FALSE)
} }
if (length(iListArgs2$BoolCrit) != LLL) { if (length(iListArgs2$BoolCrit) != L2) {
stop("'BoolCrit' and the period defined in 'RunOptions' must have the same length", call. = FALSE) stop("'BoolCrit' and the period defined in 'RunOptions' must have the same length", call. = FALSE)
} }
...@@ -283,13 +305,6 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -283,13 +305,6 @@ CreateInputsCrit <- function(FUN_CRIT,
}) })
names(InputsCrit) <- paste0("IC", seq_along(InputsCrit)) names(InputsCrit) <- paste0("IC", seq_along(InputsCrit))
## define FUN_CRIT as a characater string
listErrorCrit <- c("ErrorCrit_KGE", "ErrorCrit_KGE2", "ErrorCrit_NSE", "ErrorCrit_RMSE")
InputsCrit <- lapply(InputsCrit, function(i) {
i$FUN_CRIT <- listErrorCrit[sapply(listErrorCrit, function(j) identical(i$FUN_CRIT, get(j)))]
i
})
listVarObs <- sapply(InputsCrit, FUN = "[[", "VarObs") listVarObs <- sapply(InputsCrit, FUN = "[[", "VarObs")
inCnVarObs <- c("SCA", "SWE") inCnVarObs <- c("SCA", "SWE")
if (!"ZLayers" %in% names(InputsModel)) { if (!"ZLayers" %in% names(InputsModel)) {
...@@ -314,7 +329,7 @@ CreateInputsCrit <- function(FUN_CRIT, ...@@ -314,7 +329,7 @@ CreateInputsCrit <- function(FUN_CRIT,
## define idLayer as an index of the layer to use ## define idLayer as an index of the layer to use
for (iInCnVarObs in unique(listVarObs)) { for (iInCnVarObs in unique(listVarObs)) {
if (iInCnVarObs == "Q") { if (!iInCnVarObs %in% inCnVarObs) {
for (i in which(listVarObs == iInCnVarObs)) { for (i in which(listVarObs == iInCnVarObs)) {
InputsCrit[[i]]$idLayer <- NA InputsCrit[[i]]$idLayer <- NA
} }
......
ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) { ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
## Arguments check ## Arguments check
if (!inherits(OutputsModel, "OutputsModel")) { if (!inherits(OutputsModel, "OutputsModel")) {
stop("'OutputsModel' must be of class 'OutputsModel'") stop("'OutputsModel' must be of class 'OutputsModel'")
} }
EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "KGE", OutputsModel = OutputsModel, warnings = warnings) EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "KGE", OutputsModel = OutputsModel, warnings = warnings)
CritValue <- NA CritValue <- NA
SubCritValues <- rep(NA, 3) SubCritValues <- rep(NA, 3)
SubCritNames <- c("r", "alpha", "beta") SubCritNames <- c("r", "alpha", "beta")
SubCritPrint <- rep(NA, 3) SubCritPrint <- rep(NA, 3)
if (EC$CritCompute) { if (EC$CritCompute) {
## Other variables preparation ## Other variables preparation
meanVarObs <- mean(EC$VarObs[!EC$TS_ignore]) meanVarObs <- mean(EC$VarObs[!EC$TS_ignore])
meanVarSim <- mean(EC$VarSim[!EC$TS_ignore]) meanVarSim <- mean(EC$VarSim[!EC$TS_ignore])
## SubErrorCrit KGE rPearson ## SubErrorCrit KGE rPearson
SubCritPrint[1L] <- paste0(EC$CritName, " cor(sim, obs, \"pearson\") =") SubCritPrint[1L] <- paste0(EC$CritName, " cor(sim, obs, \"pearson\") =")
Numer <- sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) * (EC$VarSim[!EC$TS_ignore] - meanVarSim)) Numer <- sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) * (EC$VarSim[!EC$TS_ignore] - meanVarSim))
Deno1 <- sqrt(sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) ^ 2)) Deno1 <- sqrt(sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) ^ 2))
Deno2 <- sqrt(sum((EC$VarSim[!EC$TS_ignore] - meanVarSim) ^ 2)) Deno2 <- sqrt(sum((EC$VarSim[!EC$TS_ignore] - meanVarSim) ^ 2))
if (Numer == 0) { if (Numer == 0) {
if (Deno1 == 0 & Deno2 == 0) { if (Deno1 == 0 & Deno2 == 0) {
Crit <- 1 Crit <- 1
...@@ -36,13 +36,13 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T ...@@ -36,13 +36,13 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
SubCritValues[1L] <- Crit SubCritValues[1L] <- Crit
} }
## SubErrorCrit KGE alpha ## SubErrorCrit KGE alpha
SubCritPrint[2L] <- paste0(EC$CritName, " sd(sim)/sd(obs) =") SubCritPrint[2L] <- paste0(EC$CritName, " sd(sim)/sd(obs) =")
Numer <- sd(EC$VarSim[!EC$TS_ignore]) Numer <- sd(EC$VarSim[!EC$TS_ignore])
Denom <- sd(EC$VarObs[!EC$TS_ignore]) Denom <- sd(EC$VarObs[!EC$TS_ignore])
if (Numer == 0 & Denom == 0) { if (Numer == 0 & Denom == 0) {
Crit <- 1 Crit <- 1
} else { } else {
...@@ -51,10 +51,10 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T ...@@ -51,10 +51,10 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
SubCritValues[2L] <- Crit SubCritValues[2L] <- Crit
} }
## SubErrorCrit KGE beta ## SubErrorCrit KGE beta
SubCritPrint[3L] <- paste0(EC$CritName, " mean(sim)/mean(obs) =") SubCritPrint[3L] <- paste0(EC$CritName, " mean(sim)/mean(obs) =")
if (meanVarSim == 0 & meanVarObs == 0) { if (meanVarSim == 0 & meanVarObs == 0) {
Crit <- 1 Crit <- 1
} else { } else {
...@@ -63,20 +63,20 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T ...@@ -63,20 +63,20 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
SubCritValues[3L] <- Crit SubCritValues[3L] <- Crit
} }
## ErrorCrit ## ErrorCrit
if (sum(is.na(SubCritValues)) == 0) { if (sum(is.na(SubCritValues)) == 0) {
CritValue <- (1 - sqrt((SubCritValues[1L] - 1)^2 + (SubCritValues[2L] - 1)^2 + (SubCritValues[3L] - 1)^2)) CritValue <- (1 - sqrt((SubCritValues[1L] - 1)^2 + (SubCritValues[2L] - 1)^2 + (SubCritValues[3L] - 1)^2))
} }
## Verbose ## Verbose
if (verbose) { if (verbose) {
message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue)) message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue))
message(paste("\tSubCrit.", SubCritPrint, sprintf("%.4f", SubCritValues), "\n", sep = " ")) message(paste("\tSubCrit.", SubCritPrint, sprintf("%.4f", SubCritValues), "\n", sep = " "))
} }
} }
## Output ## Output
OutputsCrit <- list(CritValue = CritValue, OutputsCrit <- list(CritValue = CritValue,
CritName = EC$CritName, CritName = EC$CritName,
...@@ -85,8 +85,11 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T ...@@ -85,8 +85,11 @@ ErrorCrit_KGE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
CritBestValue = EC$CritBestValue, CritBestValue = EC$CritBestValue,
Multiplier = EC$Multiplier, Multiplier = EC$Multiplier,
Ind_notcomputed = EC$Ind_TS_ignore) Ind_notcomputed = EC$Ind_TS_ignore)
class(OutputsCrit) <- c("KGE", "ErrorCrit") class(OutputsCrit) <- c("KGE", "ErrorCrit")
return(OutputsCrit) return(OutputsCrit)
} }
class(ErrorCrit_KGE) <- c("FUN_CRIT", class(ErrorCrit_KGE))
ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) { ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
## Arguments check ## Arguments check
if (!inherits(OutputsModel, "OutputsModel")) { if (!inherits(OutputsModel, "OutputsModel")) {
stop("'OutputsModel' must be of class 'OutputsModel'") stop("'OutputsModel' must be of class 'OutputsModel'")
} }
EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "KGE2", OutputsModel = OutputsModel, warnings = warnings) EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "KGE2", OutputsModel = OutputsModel, warnings = warnings)
CritValue <- NA CritValue <- NA
SubCritValues <- rep(NA, 3) SubCritValues <- rep(NA, 3)
SubCritNames <- c("r", "gamma", "beta") SubCritNames <- c("r", "gamma", "beta")
SubCritPrint <- rep(NA, 3) SubCritPrint <- rep(NA, 3)
if (EC$CritCompute) { if (EC$CritCompute) {
## Other variables preparation ## Other variables preparation
meanVarObs <- mean(EC$VarObs[!EC$TS_ignore]) meanVarObs <- mean(EC$VarObs[!EC$TS_ignore])
meanVarSim <- mean(EC$VarSim[!EC$TS_ignore]) meanVarSim <- mean(EC$VarSim[!EC$TS_ignore])
## SubErrorCrit KGE rPearson ## SubErrorCrit KGE rPearson
SubCritPrint[1L] <- paste0(EC$CritName, " cor(sim, obs, \"pearson\") =") SubCritPrint[1L] <- paste0(EC$CritName, " cor(sim, obs, \"pearson\") =")
Numer <- sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) * (EC$VarSim[!EC$TS_ignore] - meanVarSim)) Numer <- sum((EC$VarObs[!EC$TS_ignore] - meanVarObs) * (EC$VarSim[!EC$TS_ignore] - meanVarSim))
Deno1 <- sqrt(sum((EC$VarObs[!EC$TS_ignore] - meanVarObs)^2)) Deno1 <- sqrt(sum((EC$VarObs[!EC$TS_ignore] - meanVarObs)^2))
Deno2 <- sqrt(sum((EC$VarSim[!EC$TS_ignore] - meanVarSim)^2)) Deno2 <- sqrt(sum((EC$VarSim[!EC$TS_ignore] - meanVarSim)^2))
if (Numer == 0) { if (Numer == 0) {
if (Deno1 == 0 & Deno2 == 0) { if (Deno1 == 0 & Deno2 == 0) {
Crit <- 1 Crit <- 1
...@@ -36,10 +36,10 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = ...@@ -36,10 +36,10 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose =
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
SubCritValues[1L] <- Crit SubCritValues[1L] <- Crit
} }
## SubErrorCrit KGE gamma ## SubErrorCrit KGE gamma
SubCritPrint[2L] <- paste0(EC$CritName, " cv(sim)/cv(obs) =") SubCritPrint[2L] <- paste0(EC$CritName, " cv(sim)/cv(obs) =")
if (meanVarSim == 0) { if (meanVarSim == 0) {
if (sd(EC$VarSim[!EC$TS_ignore]) == 0) { if (sd(EC$VarSim[!EC$TS_ignore]) == 0) {
CVsim <- 1 CVsim <- 1
...@@ -48,7 +48,7 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = ...@@ -48,7 +48,7 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose =
} }
} else { } else {
CVsim <- sd(EC$VarSim[!EC$TS_ignore]) / meanVarSim CVsim <- sd(EC$VarSim[!EC$TS_ignore]) / meanVarSim
} }
if (meanVarObs == 0) { if (meanVarObs == 0) {
if (sd(EC$VarObs[!EC$TS_ignore]) == 0) { if (sd(EC$VarObs[!EC$TS_ignore]) == 0) {
...@@ -68,10 +68,10 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = ...@@ -68,10 +68,10 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose =
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
SubCritValues[2L] <- Crit SubCritValues[2L] <- Crit
} }
## SubErrorCrit KGE beta ## SubErrorCrit KGE beta
SubCritPrint[3L] <- paste0(EC$CritName, " mean(sim)/mean(obs) =") SubCritPrint[3L] <- paste0(EC$CritName, " mean(sim)/mean(obs) =")
if (meanVarSim == 0 & meanVarObs == 0) { if (meanVarSim == 0 & meanVarObs == 0) {
Crit <- 1 Crit <- 1
} else { } else {
...@@ -80,20 +80,20 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = ...@@ -80,20 +80,20 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose =
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
SubCritValues[3L] <- Crit SubCritValues[3L] <- Crit
} }
## ErrorCrit ## ErrorCrit
if (sum(is.na(SubCritValues)) == 0) { if (sum(is.na(SubCritValues)) == 0) {
CritValue <- (1 - sqrt((SubCritValues[1L] - 1)^2 + (SubCritValues[2L] - 1)^2 + (SubCritValues[3L] - 1)^2)) CritValue <- (1 - sqrt((SubCritValues[1L] - 1)^2 + (SubCritValues[2L] - 1)^2 + (SubCritValues[3L] - 1)^2))
} }
## Verbose ## Verbose
if (verbose) { if (verbose) {
message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue)) message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue))
message(paste("\tSubCrit.", SubCritPrint, sprintf("%.4f", SubCritValues), "\n", sep = " ")) message(paste("\tSubCrit.", SubCritPrint, sprintf("%.4f", SubCritValues), "\n", sep = " "))
} }
} }
## Output ## Output
OutputsCrit <- list(CritValue = CritValue, OutputsCrit <- list(CritValue = CritValue,
CritName = EC$CritName, CritName = EC$CritName,
...@@ -102,8 +102,10 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = ...@@ -102,8 +102,10 @@ ErrorCrit_KGE2 <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose =
CritBestValue = EC$CritBestValue, CritBestValue = EC$CritBestValue,
Multiplier = EC$Multiplier, Multiplier = EC$Multiplier,
Ind_notcomputed = EC$Ind_TS_ignore) Ind_notcomputed = EC$Ind_TS_ignore)
class(OutputsCrit) <- c("KGE2", "ErrorCrit") class(OutputsCrit) <- c("KGE2", "ErrorCrit")
return(OutputsCrit) return(OutputsCrit)
} }
class(ErrorCrit_KGE2) <- c("FUN_CRIT", class(ErrorCrit_KGE2))
ErrorCrit_NSE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) { ErrorCrit_NSE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = TRUE) {
## Arguments check ## Arguments check
if (!inherits(OutputsModel, "OutputsModel")) { if (!inherits(OutputsModel, "OutputsModel")) {
stop("'OutputsModel' must be of class 'OutputsModel'") stop("'OutputsModel' must be of class 'OutputsModel'")
} }
EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "NSE", OutputsModel = OutputsModel, warnings = warnings) EC <- .ErrorCrit(InputsCrit = InputsCrit, Crit = "NSE", OutputsModel = OutputsModel, warnings = warnings)
CritValue <- NA CritValue <- NA
if (EC$CritCompute) { if (EC$CritCompute) {
## Other variables preparation ## Other variables preparation
meanVarObs <- mean(EC$VarObs[!EC$TS_ignore]) meanVarObs <- mean(EC$VarObs[!EC$TS_ignore])
meanVarSim <- mean(EC$VarSim[!EC$TS_ignore]) meanVarSim <- mean(EC$VarSim[!EC$TS_ignore])
## ErrorCrit ## ErrorCrit
Emod <- sum((EC$VarSim[!EC$TS_ignore] - EC$VarObs[!EC$TS_ignore])^2) Emod <- sum((EC$VarSim[!EC$TS_ignore] - EC$VarObs[!EC$TS_ignore])^2)
Eref <- sum((EC$VarObs[!EC$TS_ignore] - mean(EC$VarObs[!EC$TS_ignore]))^2) Eref <- sum((EC$VarObs[!EC$TS_ignore] - mean(EC$VarObs[!EC$TS_ignore]))^2)
if (Emod == 0 & Eref == 0) { if (Emod == 0 & Eref == 0) {
Crit <- 0 Crit <- 0
} else { } else {
...@@ -26,22 +26,24 @@ ErrorCrit_NSE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T ...@@ -26,22 +26,24 @@ ErrorCrit_NSE <- function(InputsCrit, OutputsModel, warnings = TRUE, verbose = T
if (is.numeric(Crit) & is.finite(Crit)) { if (is.numeric(Crit) & is.finite(Crit)) {
CritValue <- Crit CritValue <- Crit
} }
## Verbose ## Verbose
if (verbose) { if (verbose) {
message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue)) message(sprintf("Crit. %s = %.4f", EC$CritName, CritValue))
} }
} }
## Output ## Output
OutputsCrit <- list(CritValue = CritValue, OutputsCrit <- list(CritValue = CritValue,
CritName = EC$CritName, CritName = EC$CritName,
CritBestValue = EC$CritBestValue, CritBestValue = EC$CritBestValue,
Multiplier = EC$Multiplier,