Commit | Line | Data |
---|---|---|
e030a6e3 BA |
1 | #' @title plot curves |
2 | #' | |
3 | #' @description Plot a range of curves in data | |
4 | #' | |
5 | #' @param data Object of class Data | |
6 | #' @param indices Range of indices (integers or dates) | |
7 | #' | |
8 | #' @export | |
1e20780e | 9 | plotCurves <- function(data, indices=seq_len(data$getSize())) |
e030a6e3 | 10 | { |
841b7f5a | 11 | yrange = quantile( sapply( indices, function(i) { |
e030a6e3 BA |
12 | serie = c(data$getCenteredSerie(i)) |
13 | if (!all(is.na(serie))) | |
14 | range(serie, na.rm=TRUE) | |
15 | c() | |
841b7f5a | 16 | }), probs=c(0.05,0.95) ) |
e030a6e3 BA |
17 | par(mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5) |
18 | for (i in seq_along(indices)) | |
19 | { | |
20 | plot(data$getSerie(indices[i]), type="l", ylim=yrange, | |
21 | xlab=ifelse(i==1,"Temps (en heures)",""), ylab=ifelse(i==1,"PM10","")) | |
1e20780e | 22 | if (i < length(indices)) |
e030a6e3 BA |
23 | par(new=TRUE) |
24 | } | |
25 | } | |
26 | ||
3d69ff21 BA |
27 | #' @title plot measured / predicted |
28 | #' | |
29 | #' @description Plot measured curve (in black) and predicted curve (in red) | |
30 | #' | |
31 | #' @param data Object return by \code{getData} | |
99f83c9a | 32 | #' @param pred Object as returned by \code{computeForecast} |
3d69ff21 BA |
33 | #' @param index Index in forecasts |
34 | #' | |
35 | #' @export | |
36 | plotPredReal <- function(data, pred, index) | |
37 | { | |
38 | horizon = length(pred$getSerie(1)) | |
3d69ff21 BA |
39 | measure = data$getSerie(pred$getIndexInData(index)+1)[1:horizon] |
40 | yrange = range( pred$getSerie(index), measure ) | |
1e20780e | 41 | par(mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5, lwd=3) |
4e95ec8f | 42 | plot(measure, type="l", ylim=yrange, xlab="Temps (en heures)", ylab="PM10") |
3d69ff21 | 43 | par(new=TRUE) |
4e95ec8f | 44 | plot(pred$getSerie(index), type="l", col="#0000FF", ylim=yrange, xlab="", ylab="") |
3d69ff21 BA |
45 | } |
46 | ||
fa8078f9 | 47 | #' @title Compute filaments |
3d69ff21 | 48 | #' |
fa8078f9 | 49 | #' @description Get similar days in the past + "past tomorrow", as black as distances are small |
3d69ff21 BA |
50 | #' |
51 | #' @param data Object as returned by \code{getData} | |
52 | #' @param index Index in data | |
53 | #' @param limit Number of neighbors to consider | |
fa8078f9 | 54 | #' @param plot Should the result be plotted? |
3d69ff21 BA |
55 | #' |
56 | #' @export | |
fa8078f9 | 57 | computeFilaments <- function(data, index, limit=60, plot=TRUE) |
3d69ff21 BA |
58 | { |
59 | index = dateIndexToInteger(index, data) | |
60 | ref_serie = data$getCenteredSerie(index) | |
61 | if (any(is.na(ref_serie))) | |
fa8078f9 | 62 | stop("computeFilaments requires a serie without NAs") |
3d69ff21 | 63 | L = length(ref_serie) |
1e20780e | 64 | |
16b1c049 | 65 | # Determine indices of no-NAs days followed by no-NAs tomorrows |
25b75559 BA |
66 | fdays = c() |
67 | for (i in 1:(index-1)) | |
16b1c049 BA |
68 | { |
69 | if ( !any(is.na(data$getSerie(i)) | is.na(data$getSerie(i+1))) ) | |
25b75559 | 70 | fdays = c(fdays, i) |
16b1c049 | 71 | } |
1e20780e | 72 | |
25b75559 | 73 | distances = sapply(fdays, function(i) { |
16b1c049 BA |
74 | sqrt( sum( (ref_serie - data$getCenteredSerie(i))^2 ) / L ) |
75 | }) | |
1e20780e | 76 | indices = sort(distances, index.return=TRUE)$ix[1:min(limit,length(distances))] |
841b7f5a | 77 | yrange = quantile( c(ref_serie, sapply( indices, function(i) { |
25b75559 | 78 | serie = c(data$getCenteredSerie(fdays[i]), data$getCenteredSerie(fdays[i]+1)) |
3d69ff21 | 79 | if (!all(is.na(serie))) |
e5aa669a | 80 | return (range(serie, na.rm=TRUE)) |
e030a6e3 | 81 | c() |
1e20780e | 82 | }) ), probs=c(0.05,0.95) ) |
3d69ff21 | 83 | grays = gray.colors(20, 0.1, 0.9) #TODO: 20 == magic number |
16b1c049 BA |
84 | min_dist = min(distances[indices]) |
85 | max_dist = max(distances[indices]) | |
86 | color_values = floor( 19.5 * (distances[indices]-min_dist) / (max_dist-min_dist) ) + 1 | |
87 | plot_order = sort(color_values, index.return=TRUE, decreasing=TRUE)$ix | |
fa8078f9 BA |
88 | colors = c(grays[ color_values[plot_order] ], "#FF0000") |
89 | if (plot) | |
3d69ff21 | 90 | { |
fa8078f9 | 91 | par(mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5, lwd=2) |
16b1c049 | 92 | for ( i in seq_len(length(indices)+1) ) |
fa8078f9 | 93 | { |
25b75559 | 94 | ii = ifelse(i<=length(indices), fdays[ indices[plot_order[i]] ], index) |
16b1c049 | 95 | plot(c(data$getCenteredSerie(ii),data$getCenteredSerie(ii+1)), |
fa8078f9 BA |
96 | ylim=yrange, type="l", col=colors[i], |
97 | xlab=ifelse(i==1,"Temps (en heures)",""), ylab=ifelse(i==1,"PM10 centré","")) | |
98 | if (i <= length(indices)) | |
99 | par(new=TRUE) | |
100 | } | |
16b1c049 | 101 | abline(v=24, lty=2, col=colors()[56]) |
3d69ff21 | 102 | } |
25b75559 | 103 | list("indices"=c(fdays[ indices[plot_order] ],index), "colors"=colors) |
3d69ff21 BA |
104 | } |
105 | ||
106 | #' @title Plot similarities | |
107 | #' | |
108 | #' @description Plot histogram of similarities (weights) | |
109 | #' | |
99f83c9a | 110 | #' @param pred Object as returned by \code{computeForecast} |
3d69ff21 BA |
111 | #' @param index Index in forecasts (not in data) |
112 | #' | |
113 | #' @export | |
114 | plotSimils <- function(pred, index) | |
115 | { | |
116 | weights = pred$getParams(index)$weights | |
117 | if (is.null(weights)) | |
118 | stop("plotSimils only works on 'Neighbors' forecasts") | |
4e95ec8f BA |
119 | par(mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5) |
120 | hist(pred$getParams(index)$weights, nclass=20, xlab="Poids", ylab="Effectif") | |
3d69ff21 BA |
121 | } |
122 | ||
123 | #' @title Plot error | |
124 | #' | |
99f83c9a | 125 | #' @description Draw error graphs, potentially from several runs of \code{computeForecast} |
3d69ff21 | 126 | #' |
99f83c9a | 127 | #' @param err Error as returned by \code{computeError} |
09cf9c19 | 128 | #' @param cols Colors for each error (default: 1,2,3,...) |
3d69ff21 BA |
129 | #' |
130 | #' @seealso \code{\link{plotPredReal}}, \code{\link{plotFilaments}}, \code{\link{plotSimils}} | |
131 | #' \code{\link{plotFbox}} | |
132 | #' | |
133 | #' @export | |
09cf9c19 | 134 | plotError <- function(err, cols=seq_along(err)) |
3d69ff21 | 135 | { |
09cf9c19 BA |
136 | if (!is.null(err$abs)) |
137 | err = list(err) | |
4e95ec8f | 138 | par(mfrow=c(2,2), mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5, lwd=2) |
3d69ff21 BA |
139 | L = length(err) |
140 | yrange = range( sapply(1:L, function(index) ( err[[index]]$abs$day ) ), na.rm=TRUE ) | |
141 | for (i in seq_len(L)) | |
142 | { | |
143 | plot(err[[i]]$abs$day, type="l", xlab=ifelse(i==1,"Temps (heures)",""), | |
09cf9c19 | 144 | ylab=ifelse(i==1,"Moyenne |y - y_hat|",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
145 | if (i < L) |
146 | par(new=TRUE) | |
147 | } | |
148 | yrange = range( sapply(1:L, function(index) ( err[[index]]$abs$indices ) ), na.rm=TRUE ) | |
149 | for (i in seq_len(L)) | |
150 | { | |
151 | plot(err[[i]]$abs$indices, type="l", xlab=ifelse(i==1,"Temps (jours)",""), | |
09cf9c19 | 152 | ylab=ifelse(i==1,"Moyenne |y - y_hat|",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
153 | if (i < L) |
154 | par(new=TRUE) | |
155 | } | |
156 | yrange = range( sapply(1:L, function(index) ( err[[index]]$MAPE$day ) ), na.rm=TRUE ) | |
157 | for (i in seq_len(L)) | |
158 | { | |
159 | plot(err[[i]]$MAPE$day, type="l", xlab=ifelse(i==1,"Temps (heures)",""), | |
09cf9c19 | 160 | ylab=ifelse(i==1,"MAPE moyen",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
161 | if (i < L) |
162 | par(new=TRUE) | |
163 | } | |
164 | yrange = range( sapply(1:L, function(index) ( err[[index]]$MAPE$indices ) ), na.rm=TRUE ) | |
165 | for (i in seq_len(L)) | |
166 | { | |
167 | plot(err[[i]]$MAPE$indices, type="l", xlab=ifelse(i==1,"Temps (jours)",""), | |
09cf9c19 | 168 | ylab=ifelse(i==1,"MAPE moyen",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
169 | if (i < L) |
170 | par(new=TRUE) | |
171 | } | |
172 | } | |
173 | ||
174 | #' @title Functional boxplot | |
175 | #' | |
176 | #' @description Draw the functional boxplot on the left, and bivariate plot on the right | |
177 | #' | |
178 | #' @param data Object return by \code{getData} | |
179 | #' @param fiter Optional filter: return TRUE on indices to process | |
fa8078f9 | 180 | #' @param plot_bivariate Should the bivariate plot appear? |
3d69ff21 BA |
181 | #' |
182 | #' @export | |
fa8078f9 | 183 | plotFbox <- function(data, filter=function(index) TRUE, plot_bivariate=TRUE) |
3d69ff21 BA |
184 | { |
185 | if (!requireNamespace("rainbow", quietly=TRUE)) | |
186 | stop("Functional boxplot requires the rainbow package") | |
187 | ||
99f83c9a | 188 | L = length(data$getCenteredSerie(2)) |
25b75559 | 189 | series_matrix = sapply(1:data$getSize(), function(index) { |
99f83c9a BA |
190 | if (filter(index)) |
191 | as.matrix(data$getSerie(index)) | |
192 | else | |
193 | rep(NA,L) | |
3d69ff21 | 194 | }) |
99f83c9a BA |
195 | # TODO: merge with previous step: only one pass should be required |
196 | no_NAs_indices = sapply( 1:ncol(series_matrix), function(i) all(!is.na(series_matrix[,i])) ) | |
197 | series_matrix = series_matrix[,no_NAs_indices] | |
3d69ff21 BA |
198 | |
199 | series_fds = rainbow::fds(seq_len(nrow(series_matrix)), series_matrix) | |
fa8078f9 BA |
200 | if (plot_bivariate) |
201 | par(mfrow=c(1,2)) | |
202 | par(mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5) | |
3d69ff21 BA |
203 | rainbow::fboxplot(series_fds, "functional", "hdr", xlab="Temps (heures)", ylab="PM10", |
204 | plotlegend=FALSE, lwd=2) | |
fa8078f9 BA |
205 | if (plot_bivariate) |
206 | rainbow::fboxplot(series_fds, "bivariate", "hdr", plotlegend=FALSE) | |
207 | } | |
208 | ||
209 | #' @title Functional boxplot on filaments | |
210 | #' | |
211 | #' @description Draw the functional boxplot on filaments obtained by \code{computeFilaments} | |
212 | #' | |
213 | #' @param data Object return by \code{getData} | |
214 | #' @param indices Indices as output by \code{computeFilaments} | |
215 | #' | |
216 | #' @export | |
217 | plotFilamentsBox = function(data, indices, ...) | |
218 | { | |
219 | past_neighbs_indices = head(indices,-1) | |
220 | plotFbox(data, function(i) i %in% past_neighbs_indices, plot_bivariate=FALSE) | |
221 | par(new=TRUE) | |
222 | # "Magic" found at http://stackoverflow.com/questions/13842560/get-xlim-from-a-plot-in-r | |
223 | usr <- par("usr") | |
224 | yr <- (usr[4] - usr[3]) / 27 | |
225 | plot(data$getSerie(tail(indices,1)), type="l", lwd=2, lty=2, | |
226 | ylim=c(usr[3] + yr, usr[4] - yr), xlab="", ylab="") | |
3d69ff21 | 227 | } |
16b1c049 BA |
228 | |
229 | #' @title Plot relative conditional variability / absolute variability | |
230 | #' | |
231 | #' @description Draw the relative conditional variability / absolute variability based on on | |
232 | #' filaments obtained by \code{computeFilaments} | |
233 | #' | |
234 | #' @param data Object return by \code{getData} | |
235 | #' @param indices Indices as output by \code{computeFilaments} | |
236 | #' | |
237 | #' @export | |
238 | plotRelativeVariability = function(data, indices, ...) | |
239 | { | |
240 | #plot left / right separated by vertical line brown dotted | |
241 | #median of 3 runs for random length(indices) series | |
242 | ref_series = t( sapply(indices, function(i) { | |
243 | c( data$getSerie(i), data$getSerie(i+1) ) | |
244 | }) ) | |
245 | ref_var = apply(ref_series, 2, sd) | |
246 | ||
247 | # Determine indices of no-NAs days followed by no-NAs tomorrows | |
25b75559 BA |
248 | fdays = c() |
249 | for (i in 1:(tail(indices,1)-1)) | |
16b1c049 BA |
250 | { |
251 | if ( !any(is.na(data$getSerie(i)) | is.na(data$getSerie(i+1))) ) | |
25b75559 | 252 | fdays = c(fdays, i) |
16b1c049 BA |
253 | } |
254 | ||
255 | # TODO: 3 == magic number | |
256 | random_var = matrix(nrow=3, ncol=48) | |
257 | for (mc in seq_len(nrow(random_var))) | |
258 | { | |
25b75559 | 259 | random_indices = sample(fdays, length(indices)) |
16b1c049 BA |
260 | random_series = t( sapply(random_indices, function(i) { |
261 | c( data$getSerie(i), data$getSerie(i+1) ) | |
262 | }) ) | |
263 | random_var[mc,] = apply(random_series, 2, sd) | |
264 | } | |
265 | random_var = apply(random_var, 2, median) | |
266 | ||
267 | yrange = range(ref_var, random_var) | |
268 | par(mar=c(4.7,5,1,1), cex.axis=1.5, cex.lab=1.5) | |
269 | plot(ref_var, type="l", col=1, lwd=3, ylim=yrange, xlab="Temps (heures)", ylab="Écart-type") | |
270 | par(new=TRUE) | |
271 | plot(random_var, type="l", col=2, lwd=3, ylim=yrange, xlab="", ylab="") | |
272 | abline(v=24, lty=2, col=colors()[56]) | |
273 | } |