dyplot.default.R

dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
                           col.Precip = c("royalblue", "lightblue"), col.Q = c("black", "orangered", "grey"), col.na = "lightgrey",
                           ylab = NULL, main = NULL,
                           plot.na = TRUE, RangeSelector = TRUE, Roller = FALSE,
                           LegendShow = c("follow", "auto", "always", "onmouseover", "never"), ...) {
  
  # barChartPrecip <- scan(file = system.file("plugins/barChartPrecip.js", package = "airGRteaching"),
  #                        what = "character", quiet = TRUE)
  
  if (! any(class(x) %in% c("PrepGR", "CalGR", "SimGR"))) {
    stop("Non convenient data for x argument. Must be of class \"PrepGR\", \"CalGR\" or \"SimGR\"")
  }
  
  if (is.null(ylab)) {
    yunit <- .TypeModelGR(x)$TimeUnit
    ylab  <- paste0(c("flow [mm/", "precip. [mm/"), yunit, "]")
  } else {
    if (length(ylab) < 2) {
      ylab <- c(ylab, "")
    }
  } 
  
  if (is.null(Qsup)) {
    Qsup <- as.numeric(rep(NA, length.out = length(x$Qobs)))
  } 
  if (!is.numeric(Qsup)) {
    stop("'Qsup' must be numeric")
  }
  if (length(Qsup) != length(x$Qobs)) {
    stop("Incorrect length of 'Qsup', must be of length ", length(x$Qobs))
  }
  if (!is.character(Qsup.name)) {
    Qsup.name <- as.character(Qsup.name)
  }
  
  
  if (any(class(x) %in% "PrepGR")) {
    data <- data.frame(DatesR = x$InputsModel$DatesR,
                       Precip = x$InputsModel$Precip,
                       Qobs   = x$Qobs,
                       Qsim   = NA,
                       Qsup   = Qsup)
    if (grepl("CemaNeige", x$TypeModel)) {
      data$Psol <- rowMeans(as.data.frame(x$InputsModel$LayerPrecip) * as.data.frame(x$InputsModel$LayerFracSolidPrecip), na.rm = TRUE)
      data$Pliq <- data$Precip - data$Psol
      data$Precip <- NULL
    } 
  } else {
    data <- data.frame(DatesR = x$OutputsModel$DatesR,
                       Precip = x$OutputsModel$Precip,
                       Qobs   = x$Qobs,
                       Qsim   = x$OutputsModel$Qsim,
                       Qsup   = Qsup)
    if (grepl("CemaNeige", x$TypeModel)) {
      data$Psol <- rowMeans(sapply(x$OutputsModel$CemaNeigeLayers, function(x) x$Psol))
      data$Pliq <- rowMeans(sapply(x$OutputsModel$CemaNeigeLayers, function(x) x$Pliq))
      data$Precip <- NULL
    }
  }
  data.xts <- xts::xts(data[, -1L], order.by = data$DatesR, tz = "UTC")
  
  
  rgba <- function(x, alpha = 1) {
    sprintf("rgba(%s, %f)", paste0(col2rgb(x), collapse = ", "), alpha)
  }
  if (length(col.Q) == 1) {
    col.Q <- c(rgba(col.Q), rgba(col.Q, alpha = 0.5), rgba(col.Q, alpha = 0.3))
  }
  if (length(col.Q) == 2) {
    col.Q <- c(rgba(col.Q[1L]), rgba(col.Q[2L]), rgba(col.Q[2L], alpha = 0.5))