dyplot.default.R 4.74 KB
Newer Older
1
2
dyplot.default <- function(x, Qsup = NULL, Qsup.name = "Qsup",
                           col.Precip = c("royalblue", "lightblue"), col.Q = c("black", "orangered", "grey"), col.na = "lightgrey",
3
                           xlab = NULL, ylab = NULL, main = NULL,
4
5
                           plot.na = TRUE, RangeSelector = TRUE, Roller = FALSE,
                           LegendShow = c("follow", "auto", "always", "onmouseover", "never"), ...) {
6
  
7
8
  # barChartPrecip <- scan(file = system.file("plugins/barChartPrecip.js", package = "airGRteaching"),
  #                        what = "character", quiet = TRUE)
9
  
unknown's avatar
unknown committed
10
  if (! any(class(x) %in% c("ObsGR", "CalGR", "SimGR"))) {
11
    stop("Non convenient data for x argument. Must be of class \"ObsGR\", \"CalGR\" or \"SimGR\"")
unknown's avatar
unknown committed
12
13
  }
  
14
15
16
17
18
19
20
21
22
23
24
25
  if (is.null(xlab)) {
    xlab <- "Time"
  }
  if (is.null(ylab)) {
    yunit <- .TypeModelGR(x)$TimeUnit
    ylab  <- paste0(c("flow [mm/", "precip. [mm/"), yunit, "]")
  } else {
    if (length(ylab) < 2) {
      ylab <- c(ylab, "")
    }
  } 
  
26
27
28
29
30
31
32
33
34
35
36
37
38
39
  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)
  }


40
  if (any(class(x) %in% "ObsGR")) {
unknown's avatar
unknown committed
41
42
    data <- data.frame(DatesR = x$InputsModel$DatesR,
                       Precip = x$InputsModel$Precip,
43
                       Qobs   = x$Qobs,
44
45
                       Qsim   = NA,
                       Qsup   = Qsup)
46
47
48
49
50
    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
    } 
unknown's avatar
unknown committed
51
52
53
54
  } else {
    data <- data.frame(DatesR = x$OutputsModel$DatesR,
                       Precip = x$OutputsModel$Precip,
                       Qobs   = x$Qobs,
55
56
                       Qsim   = x$OutputsModel$Qsim,
                       Qsup   = Qsup)
57
58
59
60
    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
unknown's avatar
unknown committed
61
62
    }
  }
63
64
  data.xts <- xts(data[, -1L], order.by = data$DatesR)

65
  
66
67
68
  rgba <- function(x, alpha = 1) {
    sprintf("rgba(%s, %f)", paste0(col2rgb(x), collapse = ", "), alpha)
  }
69
70
71
72
73
  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))
74
75
76
77
  }
  if (length(col.Precip) < 2) {
    col.Precip <- c(rgba(col.Precip), rgba(col.Precip, alpha = 0.5))
  }
78
  
79
  
80
81
82
83
84
85
  if (grepl("CemaNeige", x$TypeModel)) {
    Plim <- c(-1e-3, max(data$Psol+data$Pliq, na.rm = TRUE))
  } else {
    Plim <- c(-1e-3, max(data$Precip, na.rm = TRUE))
    col.Precip <- col.Precip[1L]
  }
unknown's avatar
unknown committed
86
  
87
  
88
  dg <- dygraph(data.xts, main = main)
89
90
  dg <- dySeries(dygraph = dg, name = "Qobs", axis = 'y' , color = col.Q[1L], drawPoints = TRUE)
  dg <- dySeries(dygraph = dg, name = "Qsim", axis = 'y' , color = col.Q[2L])
91
  dg <- dySeries(dygraph = dg, name = "Qsup", axis = 'y' , color = col.Q[3L], label = Qsup.name, strokePattern = "dashed")
92
93
  dg <- dyStackedBarGroup(dygraph = dg, name = grep("^P", colnames(data.xts), value = TRUE), axis = "y2", color = rev(col.Precip))
  dg <- dyAxis(dygraph = dg, name = "y" , label = ylab[1L],
94
               valueRange = range(data.xts[, grep("^Q", colnames(data.xts))], na.rm = TRUE) * c(0.01, 1.59))
95
  dg <- dyAxis(dygraph = dg, name = "y2", label = ylab[2L], independentTicks = FALSE,
96
               valueRange = rev(Plim) * c(2.99, 0.01))
unknown's avatar
unknown committed
97
  if (RangeSelector) {
98
    dg <- dyRangeSelector(dygraph = dg, height = 15)
unknown's avatar
unknown committed
99
  }
100
101
102
103
104
105
  if (plot.na) {
    naQ_rle <- rle(is.na(data$Qobs))
    naQ_ide <- cumsum(naQ_rle$lengths)[naQ_rle$values] +1
    naQ_ids <- naQ_ide - naQ_rle$lengths[naQ_rle$values]  -1
    IDna   <- data.frame(start = naQ_ids, end = naQ_ide)
    for (i in seq_len(nrow(IDna))) {
106
      dg <- dyShading(dygraph = dg,
107
108
109
                      from    = as.character(data$DatesR)[IDna[i, "start"]],
                      to      = as.character(data$DatesR)[IDna[i, "end"  ]],
                      color   = col.na)
110
111
    }
  }
112
  if (Roller) {
113
    dg <- dyRoller(dygraph = dg, rollPeriod = 5)
114
115
  }
  if (is.numeric(Roller)) {
116
    dg <- dyRoller(dygraph = dg, rollPeriod = Roller)
117
118
  }
  if (any(LegendShow %in% c("follow", "auto", "always", "onmouseover", "never"))) {
119
    dg <- dyLegend(dygraph = dg, show = LegendShow[1L])
120
  }
121
  dg <- dyOptions(dygraph = dg, useDataTimezone = TRUE)
122
  
123
  return(dg)
unknown's avatar
unknown committed
124
125
  
}