Forked from HYCAR-Hydro / airGR
Source project has a limited visibility.
plot.OutputsModel.R 38.08 KiB
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)