Failed to fetch fork details. Try again later.
-
Delaigue Olivier authored
when which = "ActuEvap" or which = "All" overlaid to potential evapotranspiration if already drawn
aee3e2cf
Forked from
HYCAR-Hydro / airGR
Source project has a limited visibility.
plot.OutputsModel <- function(x, Qobs = NULL, IndPeriod_Plot = NULL, BasinArea = NULL, which = "synth", log_scale = FALSE,
cex.axis = 1, cex.lab = 0.9, cex.leg = 0.9, lwd = 1,
LayoutMat = NULL, LayoutWidths = rep.int(1, ncol(LayoutMat)), LayoutHeights = rep.int(1, nrow(LayoutMat)),
verbose = TRUE, ...) {
## save default graphical parameters and resetting on exit
opar <- par(no.readonly = TRUE)
on.exit(par(opar))
OutputsModel <- x
## ---------- check arguments
if (!inherits(OutputsModel, "GR") & !inherits(OutputsModel, "CemaNeige")) {
stop("'OutputsModel' not in the correct format for default plotting")
}
## check 'OutputsModel'
BOOL_Dates <- FALSE
if ("DatesR" %in% names(OutputsModel)) {
BOOL_Dates <- TRUE
}
BOOL_Pobs <- FALSE
if ("Precip" %in% names(OutputsModel)) {
BOOL_Pobs <- TRUE
}
BOOL_EPobs <- FALSE
if ("PotEvap" %in% names(OutputsModel)) {
BOOL_EPobs <- TRUE
}
BOOL_EAobs <- FALSE
if ("AE" %in% names(OutputsModel)) {
BOOL_EAobs <- TRUE
}
BOOL_Qsim <- FALSE
if ("Qsim" %in% names(OutputsModel)) {
BOOL_Qsim <- TRUE
}
BOOL_Qobs <- FALSE
if (BOOL_Qsim & length(Qobs) == length(OutputsModel$Qsim)) {
if (sum(is.na(Qobs)) != length(Qobs)) {
BOOL_Qobs <- TRUE
}
} else if (inherits(OutputsModel, "GR") & !is.null(Qobs)) {
warning("incorrect length of 'Qobs'. Time series of observed flow not drawn")
}
BOOL_Error <- FALSE
if (BOOL_Qsim & BOOL_Qobs) {
BOOL_Error <- TRUE
}
BOOL_Snow <- FALSE
if ("CemaNeigeLayers" %in% names(OutputsModel)) {
if ("SnowPack" %in% names(OutputsModel$CemaNeigeLayers[[1]])) {
BOOL_Snow <- TRUE
}
}
BOOL_Psol <- FALSE
if ("CemaNeigeLayers" %in% names(OutputsModel)) {
7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
if ("Psol" %in% names(OutputsModel$CemaNeigeLayers[[1]])) {
BOOL_Psol <- TRUE
}
}
## check 'which'
whichNeedQobs <- c("Error", "CorQQ")
whichDashboard <- c("all", "synth", "ts", "evap", "perf")
whichAll <- c("Precip", "PotEvap", "ActuEvap", "Temp", "SnowPack", "Flows", "Error", "Regime", "CumFreq", "CorQQ")
whichSynth <- c("Precip" , "Temp", "SnowPack", "Flows" , "Regime", "CumFreq", "CorQQ")
whichTS <- c("Precip", "PotEvap", "Temp", "SnowPack", "Flows" )
whichEvap <- c( "PotEvap", "ActuEvap" )
whichPerf <- c( "Error", "Regime", "CumFreq", "CorQQ")
whichCN <- c( "Temp", "SnowPack" )
warnMsgWhich <- "'which' must be a vector of character"
warnMsgNoQobs <- "the %s plot(s) cannot be drawn if there is no 'Qobs'"
warnMsgWhichCN <- sprintf("incorrect element found in argument 'which':\n\twithout CemaNeige, %s are not available \n\tit can only contain %s",
paste0(shQuote(whichCN), collapse = " and "),
paste0(shQuote(c(whichDashboard, whichAll[!whichAll %in% whichCN])), collapse = ", "))
if (is.null(which)) {
stop(warnMsgWhich)
}
if (!is.vector(which)) {
stop(warnMsgWhich)
}
if (!is.character(which)) {
stop(warnMsgWhich)
}
if (any(!which %in% c(whichDashboard, whichAll))) {
stop(sprintf("incorrect element found in argument 'which': %s\nit can only contain %s",
paste0(shQuote(which[!which %in% c(whichDashboard, whichAll)])),
paste0(shQuote(c(whichDashboard, whichAll)), collapse = ", ")))
}
if (all(which %in% whichCN) & !inherits(OutputsModel, "CemaNeige")) {
stop(warnMsgWhichCN)
}
if (length(unique(which %in% whichCN)) == 2 & !inherits(OutputsModel, "CemaNeige")) {
warning(warnMsgWhichCN)
}
if (all(!which %in% c("all", "synth", "ts", whichCN)) & !inherits(OutputsModel, "GR")) {
stop(sprintf("incorrect element found in argument 'which': \nwith CemaNeige alone, only %s are available",
paste0(shQuote(c("all", "synth", "ts", "Temp", "SnowPack")), collapse = ", ")))
}
if (any(!which %in% c("all", "synth", "ts", whichCN)) & !inherits(OutputsModel, "GR")) {
warning(sprintf("incorrect element found in argument 'which': \nwith CemaNeige alone, only %s are available",
paste0(shQuote(c("all", "synth", "ts", "Temp", "SnowPack")), collapse = ", ")))
}
if ("perf" %in% which) {
which <- c(which, whichPerf)
}
if ("ts" %in% which) {
which <- c(which, whichTS)
}
if ("evap" %in% which) {
which <- c(which, whichEvap)
}
if ("synth" %in% which) {
which <- c(which, whichSynth)
}
if ("all" %in% which) {
which <- c(which, whichAll)
}
if (is.null(Qobs) & inherits(OutputsModel, "GR")) {
if (length(which) == 1 & (any(which %in% whichNeedQobs))) {
stop(sprintf(warnMsgNoQobs, shQuote(which)))
}
if (length(which) != 1 & any(which %in% whichNeedQobs)) {
BOOL_CorQQ <- FALSE
BOOL_Error <- FALSE
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
warning(sprintf(warnMsgNoQobs, paste0(shQuote(whichNeedQobs), collapse = " and ")))
}
}
## check dates
if (!BOOL_Dates) {
stop("'OutputsModel' must contain at least 'DatesR' to allow plotting")
}
if (inherits(OutputsModel, "GR") & !BOOL_Qsim) {
stop("'OutputsModel' must contain at least 'Qsim' to allow plotting")
}
if (BOOL_Dates) {
MyRollMean1 <- function(x, n) {
return(filter(x, rep(1 / n, n), sides = 2))
}
MyRollMean2 <- function(x, n) {
return(filter(c(tail(x, n %/% 2), x, x[1:(n %/% 2)]), rep(1 / n, n), sides = 2)[(n %/% 2 + 1):(length(x) + n %/% 2)])
}
MyRollMean3 <- function(x, n) {
return(filter(x, filter = rep(1 / n, n), sides = 2, circular = TRUE))
}
BOOL_TS <- FALSE
TimeStep <- difftime(tail(OutputsModel$DatesR, 1), tail(OutputsModel$DatesR, 2), units = "secs")[[1]]
if (inherits(OutputsModel, "hourly") &
TimeStep %in% (60 * 60)) {
BOOL_TS <- TRUE
NameTS <- "hour"
plotunit <- "[mm/h]"
formatAxis <- "%m/%Y"
}
if (inherits(OutputsModel, "daily") &
TimeStep %in% (24 * 60 * 60)) {
BOOL_TS <- TRUE
NameTS <- "day"
plotunit <- "[mm/d]"
formatAxis <- "%m/%Y"
}
if (inherits(OutputsModel, "monthly") &
TimeStep %in% (c(28, 29, 30, 31) * 24 * 60 * 60)) {
BOOL_TS <- TRUE
NameTS <- "month"
plotunit <- "[mm/month]"
formatAxis <- "%m/%Y"
if (format(OutputsModel$DatesR[1L], format = "%d") != "01") {
OutputsModel$DatesR <- as.POSIXlt(format(OutputsModel$DatesR, format = "%Y-%m-01"), tz = "UTC", format = "%Y-%m-%d")
}
}
if (inherits(OutputsModel, "yearly") &
TimeStep %in% (c(365, 366) * 24 * 60 * 60)) {
BOOL_TS <- TRUE
NameTS <- "year"
plotunit <- "[mm/y]"
formatAxis <- "%Y"
}
if (!BOOL_TS) {
stop("the time step of the model inputs could not be found")
}
}
if (length(IndPeriod_Plot) == 0) {
IndPeriod_Plot <- 1:length(OutputsModel$DatesR)
}
if (inherits(OutputsModel, "CemaNeige")) {
NLayers <- length(OutputsModel$CemaNeigeLayers)
}
PsolLayerMean <- NULL
if (BOOL_Psol) {
for (iLayer in 1:NLayers) {
if (iLayer == 1) {
211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
PsolLayerMean <- OutputsModel$CemaNeigeLayers[[iLayer]]$Psol / NLayers
} else {
PsolLayerMean <- PsolLayerMean + OutputsModel$CemaNeigeLayers[[iLayer]]$Psol / NLayers
}
}
}
BOOL_QobsZero <- FALSE
if (BOOL_Qobs) {
SelectQobsNotZero <- round(Qobs[IndPeriod_Plot], 4) != 0
BOOL_QobsZero <- sum(!SelectQobsNotZero, na.rm = TRUE) > 0
}
BOOL_QsimZero <- FALSE
if (BOOL_Qsim) {
SelectQsimNotZero <- round(OutputsModel$Qsim[IndPeriod_Plot], 4) != 0
BOOL_QsimZero <- sum(!SelectQsimNotZero, na.rm = TRUE) > 0
}
if ( BOOL_Qobs & !BOOL_Qsim) {
SelectNotZero <- SelectQobsNotZero
}
if (!BOOL_Qobs & BOOL_Qsim) {
SelectNotZero <- SelectQsimNotZero
}
if ( BOOL_Qobs & BOOL_Qsim) {
SelectNotZero <- SelectQobsNotZero & SelectQsimNotZero
}
if (BOOL_QobsZero & verbose) {
warning("zeroes detected in 'Qobs': some plots in the log space will not be created using all time-steps")
}
if (BOOL_QsimZero & verbose) {
warning("zeroes detected in 'Qsim': some plots in the log space will not be created using all time-steps")
}
BOOL_FilterZero <- TRUE
## ---------- plot
## plot choices
BOOLPLOT_Precip <- "Precip" %in% which & BOOL_Pobs
BOOLPLOT_PotEvap <- "PotEvap" %in% which & BOOL_EPobs
BOOLPLOT_ActuEvap <- "ActuEvap" %in% which & BOOL_EAobs
BOOLPLOT_Temp <- "Temp" %in% which & BOOL_Snow
BOOLPLOT_SnowPack <- "SnowPack" %in% which & BOOL_Snow
BOOLPLOT_Flows <- "Flows" %in% which & (BOOL_Qsim | BOOL_Qobs)
BOOLPLOT_Error <- "Error" %in% which & BOOL_Error
BOOLPLOT_Regime <- "Regime" %in% which & BOOL_Qsim & BOOL_TS & (NameTS %in% c("hour", "day", "month"))
BOOLPLOT_CumFreq <- "CumFreq" %in% which & (BOOL_Qsim | BOOL_Qobs) & BOOL_FilterZero
BOOLPLOT_CorQQ <- "CorQQ" %in% which & (BOOL_Qsim & BOOL_Qobs) & BOOL_FilterZero
## options
BLOC <- TRUE
if (BLOC) {
lwdk <- 1.8
line <- 2.6
bg <- NA
## Set plot arrangement
if (is.null(LayoutMat)) {
matlayout <- NULL
iPlot <- 0
iHght <- NULL
listBOOLPLOT1 <- c(Precip = BOOLPLOT_Precip,
PotEvap = BOOLPLOT_PotEvap | BOOLPLOT_ActuEvap,
Temp = BOOLPLOT_Temp , SnowPack = BOOLPLOT_SnowPack,
Flows = BOOLPLOT_Flows , Error = BOOLPLOT_Error)
listBOOLPLOT2 <- c(Regime = BOOLPLOT_Regime, CumFreq = BOOLPLOT_CumFreq,
CorQQ = BOOLPLOT_CorQQ)
Sum1 <- sum(listBOOLPLOT1)