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