/
bfast.R
255 lines (253 loc) · 11.3 KB
/
bfast.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
#' Break Detection in the Seasonal and Trend Component of a Univariate Time
#' Series
#'
#' Iterative break detection in seasonal and trend component of a time series.
#' Seasonal breaks is a function that combines the iterative decomposition of
#' time series into trend, seasonal and remainder components with significant
#' break detection in the decomposed components of the time series.
#'
#' The algorithm decomposes the input time series `Yt` into three components:
#' trend, seasonality and remainder, using the function defined by the `decomp`
#' parameter. Then each component is checked for at least one significant
#' break using [strucchangeRcpp::efp()], and if there is one, [strucchangeRcpp::breakpoints()]
#' is run on the component. The result allows differentiating between breaks in
#' trend and seasonality.
#'
#' @param Yt univariate time series to be analyzed. This should be an object of
#' class "ts" with a frequency greater than one.
#' @param h minimal segment size between potentially detected breaks in the
#' trend model given as fraction relative to the sample size (i.e. the minimal
#' number of observations in each segment divided by the total length of the
#' timeseries).
#' @param season the seasonal model used to fit the seasonal component and
#' detect seasonal breaks (i.e. significant phenological change). There are
#' three options: "dummy", "harmonic", or "none" where "dummy" is the model
#' proposed in the first Remote Sensing of Environment paper and "harmonic" is
#' the model used in the second Remote Sensing of Environment paper (See paper
#' for more details) and where "none" indicates that no seasonal model will be
#' fitted (i.e. St = 0 ). If there is no seasonal cycle (e.g. frequency of the
#' time series is 1) "none" can be selected to avoid fitting a seasonal model.
#' @param max.iter maximum amount of iterations allowed for estimation of
#' breakpoints in seasonal and trend component.
#' @param breaks integer specifying the maximal number of breaks to be
#' calculated. By default the maximal number allowed by h is used.
#' @param hpc A character specifying the high performance computing support.
#' Default is "none", can be set to "foreach". Install the "foreach" package
#' for hpc support.
#' @param level numeric; threshold value for the \link[strucchangeRcpp]{sctest.efp}
#' test; if a length 2 vector is passed, the first value is used for the trend,
#' the second for the seasonality
#' @param decomp "stlplus" or "stl": the function to use for decomposition.
#' \code{stl} can handle sparse time series (1 < frequency < 4), \code{stlplus}
#' can handle \code{NA} values in the time series.
#' @param type character, indicating the type argument to
#' \link[strucchangeRcpp]{efp}
#' @param \dots additional arguments passed to [stlplus::stlplus()], if
#' its usage has been enabled, otherwise ignored.
#' @return An object of the class "bfast" is a list with the following
#' elements: \item{Yt}{ equals the Yt used as input.} \item{output}{ is a list
#' with the following elements (for each iteration): \tabular{ll}{ \code{Tt}
#' \tab the fitted trend component\cr \code{St} \tab the fitted seasonal
#' component\cr \code{Nt} \tab the noise or remainder component\cr \code{Vt}
#' \tab equals the deseasonalized data \code{Yt - St} for each iteration\cr
#' \code{bp.Vt} \tab output of the \code{\link[strucchangeRcpp]{breakpoints}}
#' function for the trend model. Note that the output breakpoints are index
#' numbers of \code{na.omit(as.numeric(Vt))}.\cr \code{ci.Vt} \tab output of the
#' \code{\link[strucchangeRcpp]{breakpoints}} confint function for the trend
#' model\cr \code{Wt} \tab equals the detrended data \code{Yt - Tt} for each
#' iteration\cr \code{bp.Wt} \tab output of the
#' \code{\link[strucchangeRcpp]{breakpoints}} function for the seasonal model.
#' Note that the output breakpoints are index numbers of \code{na.omit(as.numeric(Wt))}. \cr
#' \code{ci.Wt} \tab output of the \code{\link[strucchangeRcpp]{breakpoints}}
#' confint function for the seasonal model }} \item{nobp}{ is a list with the
#' following elements: \tabular{ll}{ \code{nobp.Vt} \tab logical, TRUE if there
#' are no breakpoints detected\cr \code{nobp.Wt} \tab logical, TRUE if there
#' are no breakpoints detected }} \item{Magnitude}{ magnitude of the biggest
#' change detected in the trend component} \item{Time}{ timing of the biggest
#' change detected in the trend component}
#' @author Jan Verbesselt
#' @seealso \code{\link[bfast]{plot.bfast}} for plotting of bfast() results.
#' \cr \code{\link[strucchangeRcpp]{breakpoints}} for more examples and background
#' information about estimation of breakpoints in time series.
#' @references \insertRef{janbfast}{bfast}
#'
#' \insertRef{janbfastpheno}{bfast}
#' @keywords ts
#' @example examples/bfast.r
#'
#' @export bfast
bfast <- function (Yt, h = 0.15, season = c("dummy", "harmonic", "none"),
max.iter = 10, breaks = NULL, hpc = "none", level = 0.05,
decomp = c("stl", "stlplus"),
type = "OLS-MOSUM", ...)
{
# Error catching
decomp = match.arg(decomp)
if (decomp == "stl" && any(is.na(Yt))) {
warning("The stl() function cannot deal with missing values in the time series, falling back to decomp='stlplus'.")
decomp <- "stlplus"
}
if(decomp == "stlplus" && !requireNamespace("stlplus", quietly = TRUE)) {
warning("stlplus package could not be loaded, falling back to decomp='stl'.")
decomp <- "stl"
}
## Get Arguments
season <- match.arg(season)
level <- rep(level, length.out = 2)
ti <- time(Yt)
f <- frequency(Yt) # on cycle every f time points (seasonal cycle)
if (class(Yt) != "ts")
stop("Not a time series object")
if (f < 1)
stop("Time series frequency needs to be more than 1")
if (decomp == "stlplus" && f < 4) {
warning("Not enough seasons (frequency < 4) for using stlplus decomposition, falling back to decomp = 'stl'")
decomp <- "stl"
}
output <- list()
Tt <- 0
if (season == "harmonic") {
w <- 1/f
tl <- 1:length(Yt)
co <- cos(2 * pi * tl * w)
si <- sin(2 * pi * tl * w)
co2 <- cos(2 * pi * tl * w * 2)
si2 <- sin(2 * pi * tl * w * 2)
co3 <- cos(2 * pi * tl * w * 3)
si3 <- sin(2 * pi * tl * w * 3)
smod <- Wt ~ co + si + co2 + si2 + co3 + si3
# Start the iterative procedure and for first iteration St=decompose result
St <- if (decomp == "stlplus") {
stlplus::stlplus(Yt, t=ti, n.p = f, s.window = "periodic", ...)$data[, "seasonal"]
} else {
stl (Yt, "periodic")$time.series[, "seasonal"]
}
}
else if (season == "dummy") {
# Start the iterative procedure and for first iteration St=decompose result
St <- if (decomp == "stlplus") {
stlplus::stlplus(Yt, t = ti, n.p = f, s.window = "periodic", ...)$data[, "seasonal"]
} else {
stl(Yt, "periodic")$time.series[, "seasonal"]
}
D <- seasonaldummy(Yt)
D[rowSums(D) == 0, ] <- -1
smod <- Wt ~ -1 + D
}
else if (season == "none") {
print("No seasonal model will be fitted!")
St <- 0
}
else stop("Not a correct seasonal model is selected ('harmonic' or 'dummy') ")
Vt.bp <- 0
Wt.bp <- 0
CheckTimeTt <- 1
CheckTimeSt <- 1
i <- 0
while ((!identical(CheckTimeTt, Vt.bp) | !identical(CheckTimeSt, Wt.bp)) & i < max.iter) {
CheckTimeTt <- Vt.bp
CheckTimeSt <- Wt.bp
### Change in trend component
Vt <- Yt - St # Deasonalized Time series
p.Vt <- sctest(efp(Vt ~ ti, h = h, type = type))
if (p.Vt$p.value <= level[1]) {
bp.Vt <- breakpoints(Vt ~ ti, h = h, breaks = breaks, na.action=na.exclude,hpc = hpc)
nobp.Vt <- is.na(breakpoints(bp.Vt)[1])
} else {
nobp.Vt <- TRUE
bp.Vt <- NA
}
if (nobp.Vt) {
## No Change detected
fm0 <- lm(Vt ~ ti)
Vt.bp <- 0 # no breaks times
Tt <- ts(data=NA,start = ti[1], end = ti[length(ti)],frequency = f) # Data minus trend
Tt[which(!is.na(Yt))] <- fitted(fm0) # Overwrite non-missing with fitted values
tsp(Tt) <- tsp(Yt)
ci.Vt <- NA
} else {
fm1 <- lm(Vt[which(!is.na(Yt))] ~ breakfactor(bp.Vt)/ti[which(!is.na(Yt))] )
ci.Vt <- confint(bp.Vt, het.err = FALSE)
Vt.bp <- ci.Vt$confint[, 2]
# Define empty copy of original time series
Tt <- ts(data=NA,start = ti[1], end = ti[length(ti)],frequency = f)
Tt[which(!is.na(Yt))] <- fitted(fm1) # Overwrite non-missing with fitted values
tsp(Tt) <- tsp(Yt)
}
if (season == "none") {
Wt <- 0
St <- 0
bp.Wt <- NA
ci.Wt <- NA
nobp.Wt <- TRUE
} else {
### Change in seasonal component
Wt <- Yt - Tt
p.Wt <- sctest(efp(smod, h = h, type = type)) # preliminary test
if (p.Wt$p.value <= level[2]) {
bp.Wt <- breakpoints(smod, h = h, breaks = breaks,
hpc = hpc)
nobp.Wt <- is.na(breakpoints(bp.Wt)[1])
}
else {
nobp.Wt <- TRUE
bp.Wt <- NA
}
if (nobp.Wt) {
## No seasonal change detected
sm0 <- lm(smod)
St <- ts(data=NA,start = ti[1], end = ti[length(ti)],frequency = f)
St[which(!is.na(Yt))] <- fitted(sm0) # Overwrite non-missing with fitted values
tsp(St) <- tsp(Yt)
Wt.bp <- 0
ci.Wt <- NA
} else {
if (season == "dummy")
sm1 <- lm(Wt[!is.na(Wt)] ~ -1 + D[!is.na(Wt),] %in% breakfactor(bp.Wt))
if (season == "harmonic")
sm1 <- lm(Wt[!is.na(Wt)] ~ (
co[!is.na(Wt)] + si[!is.na(Wt)] + co2[!is.na(Wt)] + si2[!is.na(Wt)] + co3[!is.na(Wt)] + si3[!is.na(Wt)]
) %in% breakfactor(bp.Wt))
ci.Wt <- confint(bp.Wt, het.err = FALSE)
Wt.bp <- ci.Wt$confint[, 2]
# Define empty copy of original time series
St <- ts(data=NA,start = ti[1], end = ti[length(ti)],frequency = f)
St[which(!is.na(Yt))] <- fitted(sm1) # Overwrite non-missing with fitted values
tsp(St) <- tsp(Yt)
}
}
i <- i + 1
output[[i]] <- list(Tt = Tt, St = St, Nt = Yt - Tt - St, Vt = Vt, bp.Vt = bp.Vt, Vt.bp = Vt.bp, ci.Vt = ci.Vt,
Wt = Wt, bp.Wt = bp.Wt, Wt.bp = Wt.bp, ci.Wt = ci.Wt)
}
if (!nobp.Vt) { # probably only works well for dummy model!
Vt.nrbp <- length(bp.Vt$breakpoints)
co <- coef(fm1) # final fitted trend model
Mag <- matrix(NA, Vt.nrbp, 3)
for (r in 1:Vt.nrbp) {
if (r == 1) {
y1 <- co[1] + co[r + Vt.nrbp + 1] * ti[Vt.bp[r]]
} else {
y1 <- co[1] + co[r] + co[r + Vt.nrbp + 1] * ti[Vt.bp[r]]
}
y2 <- (co[1] + co[r + 1]) + co[r + Vt.nrbp + 2] * ti[Vt.bp[r] + 1]
Mag[r, 1] <- y1
Mag[r, 2] <- y2
Mag[r, 3] <- y2 - y1
}
index <- which.max(abs(Mag[, 3]))
m.x <- rep(Vt.bp[index], 2)
m.y <- c(Mag[index, 1], Mag[index, 2]) #Magnitude position
Magnitude <- Mag[index, 3] # Magnitude of biggest change
Time <- Vt.bp[index]
} else {
m.x <- NA
m.y <- NA
Magnitude <- 0 # if we do not detect a break then the magnitude is zero
Time <- NA # if we do not detect a break then we have no timing of the break
Mag <- 0
}
return(structure(list(Yt = Yt, output = output, nobp = list(Vt = nobp.Vt, Wt = nobp.Wt),
Magnitude = Magnitude, Mags = Mag, Time = Time,
jump = list(x = ti[m.x], y = m.y)), class = "bfast"))
}