Commit | Line | Data |
---|---|---|
3d69ff21 BA |
1 | #' @title plot measured / predicted |
2 | #' | |
3 | #' @description Plot measured curve (in black) and predicted curve (in red) | |
4 | #' | |
5 | #' @param data Object return by \code{getData} | |
6 | #' @param pred Object as returned by \code{getForecast} | |
7 | #' @param index Index in forecasts | |
8 | #' | |
9 | #' @export | |
10 | plotPredReal <- function(data, pred, index) | |
11 | { | |
12 | horizon = length(pred$getSerie(1)) | |
13 | par(mar=c(4.7,5,1,1), cex.axis=2, cex.lab=2, lwd=2) | |
14 | measure = data$getSerie(pred$getIndexInData(index)+1)[1:horizon] | |
15 | yrange = range( pred$getSerie(index), measure ) | |
09cf9c19 | 16 | plot(measure, type="l", ylim=yrange, lwd=3, xlab="Temps (en heures)", ylab="PM10") |
3d69ff21 | 17 | par(new=TRUE) |
09cf9c19 | 18 | plot(pred$getSerie(index), type="l", col="#0000FF", ylim=yrange, lwd=3, xlab="", ylab="") |
3d69ff21 BA |
19 | } |
20 | ||
21 | #' @title Plot filaments | |
22 | #' | |
23 | #' @description Plot similar days in the past + "past tomorrow", as black as distances are small | |
24 | #' | |
25 | #' @param data Object as returned by \code{getData} | |
26 | #' @param index Index in data | |
27 | #' @param limit Number of neighbors to consider | |
28 | #' | |
29 | #' @export | |
30 | plotFilaments <- function(data, index, limit=60) | |
31 | { | |
32 | index = dateIndexToInteger(index, data) | |
33 | ref_serie = data$getCenteredSerie(index) | |
34 | if (any(is.na(ref_serie))) | |
35 | stop("plotFilaments requires a serie without NAs") | |
36 | L = length(ref_serie) | |
37 | first_day = ifelse(length(data$getCenteredSerie(1)<L), 2, 1) | |
38 | distances = sapply(first_day:(index-1), function(i) { | |
39 | sqrt( sum( (ref_serie - data$getCenteredSerie(i))^2 ) / L ) | |
40 | }) | |
41 | # HACK to suppress NA effect while keeping indexation | |
42 | distances[is.na(distances)] = max(distances,na.rm=TRUE) + 1 | |
43 | indices = sort(distances, index.return=TRUE)$ix[1:min(limit,index-first_day)] | |
44 | yrange = range( ref_serie, sapply( indices, function(i) { | |
45 | index = i - first_day + 1 | |
46 | serie = c(data$getCenteredSerie(index), data$getCenteredSerie(index+1)) | |
47 | if (!all(is.na(serie))) | |
48 | return ( range(serie, na.rm=TRUE) ) | |
49 | return (0) | |
50 | }) ) | |
51 | grays = gray.colors(20, 0.1, 0.9) #TODO: 20 == magic number | |
52 | colors = c( | |
53 | grays[ floor( 20.5 * distances[indices] / (1+max(distances[indices])) ) ], "#FF0000") | |
54 | par(mar=c(4.7,5,1,1), cex.axis=2, cex.lab=2, lwd=2) | |
55 | for (i in seq_len(length(indices)+1)) | |
56 | { | |
57 | ind = ifelse(i<=length(indices), indices[i] - first_day + 1, index) | |
58 | plot(c(data$getCenteredSerie(ind),data$getCenteredSerie(ind+1)), | |
59 | ylim=yrange, type="l", col=colors[i], | |
60 | xlab=ifelse(i==1,"Temps (en heures)",""), ylab=ifelse(i==1,"PM10 centré","")) | |
61 | if (i <= length(indices)) | |
62 | par(new=TRUE) | |
63 | } | |
64 | } | |
65 | ||
66 | #' @title Plot similarities | |
67 | #' | |
68 | #' @description Plot histogram of similarities (weights) | |
69 | #' | |
70 | #' @param pred Object as returned by \code{getForecast} | |
71 | #' @param index Index in forecasts (not in data) | |
72 | #' | |
73 | #' @export | |
74 | plotSimils <- function(pred, index) | |
75 | { | |
76 | weights = pred$getParams(index)$weights | |
77 | if (is.null(weights)) | |
78 | stop("plotSimils only works on 'Neighbors' forecasts") | |
79 | par(mar=c(4.7,5,1,1)) | |
80 | hist(pred$getParams(index)$weights, nclass=20, xlab="Weight", ylab="Frequency") | |
81 | } | |
82 | ||
83 | #' @title Plot error | |
84 | #' | |
85 | #' @description Draw error graphs, potentially from several runs of \code{getForecast} | |
86 | #' | |
87 | #' @param err Error as returned by \code{getError} | |
09cf9c19 | 88 | #' @param cols Colors for each error (default: 1,2,3,...) |
3d69ff21 BA |
89 | #' |
90 | #' @seealso \code{\link{plotPredReal}}, \code{\link{plotFilaments}}, \code{\link{plotSimils}} | |
91 | #' \code{\link{plotFbox}} | |
92 | #' | |
93 | #' @export | |
09cf9c19 | 94 | plotError <- function(err, cols=seq_along(err)) |
3d69ff21 | 95 | { |
09cf9c19 BA |
96 | if (!is.null(err$abs)) |
97 | err = list(err) | |
3d69ff21 BA |
98 | par(mfrow=c(2,2), mar=c(4.7,5,1,1), cex.axis=2, cex.lab=2, lwd=2) |
99 | L = length(err) | |
100 | yrange = range( sapply(1:L, function(index) ( err[[index]]$abs$day ) ), na.rm=TRUE ) | |
101 | for (i in seq_len(L)) | |
102 | { | |
103 | plot(err[[i]]$abs$day, type="l", xlab=ifelse(i==1,"Temps (heures)",""), | |
09cf9c19 | 104 | ylab=ifelse(i==1,"Moyenne |y - y_hat|",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
105 | if (i < L) |
106 | par(new=TRUE) | |
107 | } | |
108 | yrange = range( sapply(1:L, function(index) ( err[[index]]$abs$indices ) ), na.rm=TRUE ) | |
109 | for (i in seq_len(L)) | |
110 | { | |
111 | plot(err[[i]]$abs$indices, type="l", xlab=ifelse(i==1,"Temps (jours)",""), | |
09cf9c19 | 112 | ylab=ifelse(i==1,"Moyenne |y - y_hat|",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
113 | if (i < L) |
114 | par(new=TRUE) | |
115 | } | |
116 | yrange = range( sapply(1:L, function(index) ( err[[index]]$MAPE$day ) ), na.rm=TRUE ) | |
117 | for (i in seq_len(L)) | |
118 | { | |
119 | plot(err[[i]]$MAPE$day, type="l", xlab=ifelse(i==1,"Temps (heures)",""), | |
09cf9c19 | 120 | ylab=ifelse(i==1,"MAPE moyen",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
121 | if (i < L) |
122 | par(new=TRUE) | |
123 | } | |
124 | yrange = range( sapply(1:L, function(index) ( err[[index]]$MAPE$indices ) ), na.rm=TRUE ) | |
125 | for (i in seq_len(L)) | |
126 | { | |
127 | plot(err[[i]]$MAPE$indices, type="l", xlab=ifelse(i==1,"Temps (jours)",""), | |
09cf9c19 | 128 | ylab=ifelse(i==1,"MAPE moyen",""), ylim=yrange, col=cols[i]) |
3d69ff21 BA |
129 | if (i < L) |
130 | par(new=TRUE) | |
131 | } | |
132 | } | |
133 | ||
134 | #' @title Functional boxplot | |
135 | #' | |
136 | #' @description Draw the functional boxplot on the left, and bivariate plot on the right | |
137 | #' | |
138 | #' @param data Object return by \code{getData} | |
139 | #' @param fiter Optional filter: return TRUE on indices to process | |
140 | #' | |
141 | #' @export | |
09cf9c19 | 142 | plotFbox <- function(data, filter=function(index) TRUE) |
3d69ff21 BA |
143 | { |
144 | if (!requireNamespace("rainbow", quietly=TRUE)) | |
145 | stop("Functional boxplot requires the rainbow package") | |
146 | ||
147 | start_index = 1 | |
148 | end_index = data$getSize() | |
149 | if (length(data$getCenteredSerie(1)) < length(data$getCenteredSerie(2))) | |
150 | { | |
151 | # Shifted start (7am, or 1pm, or...) | |
152 | start_index = 2 | |
153 | end_index = data$getSize() - 1 | |
154 | } | |
155 | ||
156 | series_matrix = sapply(start_index:end_index, function(index) { | |
157 | as.matrix(data$getSerie(index)) | |
158 | }) | |
159 | # Remove NAs. + filter TODO: merge with previous step: only one pass required... | |
160 | nas_indices = seq_len(ncol(series_matrix))[ sapply( 1:ncol(series_matrix), | |
161 | function(index) ( !filter(index) || any(is.na(series_matrix[,index])) ) ) ] | |
162 | series_matrix = series_matrix[,-nas_indices] | |
163 | ||
164 | series_fds = rainbow::fds(seq_len(nrow(series_matrix)), series_matrix) | |
165 | par(mfrow=c(1,2), mar=c(4.7,5,1,1), cex.axis=2, cex.lab=2) | |
166 | rainbow::fboxplot(series_fds, "functional", "hdr", xlab="Temps (heures)", ylab="PM10", | |
167 | plotlegend=FALSE, lwd=2) | |
168 | rainbow::fboxplot(series_fds, "bivariate", "hdr", plotlegend=FALSE) | |
169 | } |