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
|
#' Remove offsets and linear trends
#'
#' Removes the offsets or linear trends in each of the input and output matrices.
#'
#' @param x an object of class \code{idframe}
#' @param type trend type - "constant" or "linear". (Default: \code{"constant"})
#'
#' @return
#' A list containing the following elements
#'
#' \tabular{ll}{
#' \code{fitted.values} \tab \code{idframe} object with detrended variables \cr
#' \code{output_trend} \tab \code{list} containing trend fits for each output
#' variable \cr
#' \code{input_trend} \tab \code{list} containing trend fits for each input
#' variable
#' }
#'
#' @examples
#' data(cstr)
#' fit <- detrend(cstr,type="linear") # remove linear trends
#' Zdetrend <- predict(fit) # get the detrended data
#'
#' demean <- detrend(cstr) # remove offsets
#' Zcent <- predict(demean) # get the centered data
#'
#' @seealso \code{\link{predict.detrend}}, \code{\link[stats]{lm}}
#' @export
detrend <- function(x,type=c("constant","linear")[1]){
if(!(type %in% c("constant","linear"))){
stop("Error: Invalid trend type")
}
reg <- time(x)
if(type=="linear"){
formula <- X ~ reg
} else {
formula <- X ~ 1 + offset(0*reg)
}
# Return Variables
Z <- x # Detrended object
output_trend <- NULL # object containing the output trend fits/offsets
input_trend <- NULL # object containing the input trend fits/offsets
# Function which performs linear regression across every column
multilm <- function(x,formula,reg){
l <- lapply(as.list(x),function(x) data.frame(X=x,reg=reg))
trend <- lapply(l,function(x) lm(formula,data=x))
trend
}
if(nOutputSeries(x)!=0){
output_trend <- multilm(outputData(x),formula,reg)
outputData(Z) <- ts(sapply(output_trend,resid),start=reg[1],
end=tail(reg,n=1),deltat=deltat(x))
}
if(nInputSeries(x)!=0){
input_trend <- multilm(inputData(x),formula,reg)
inputData(Z) <- ts(sapply(input_trend,resid),start=reg[1],
end=tail(reg,n=1),deltat=deltat(x))
}
est <- list(fitted.values=Z,output_trend = output_trend,
input_trend = input_trend)
class(est) <- "detrend"
return(est)
}
#' Detrend data based on linear trend fits
#'
#' Returns detrended \code{idframe} object based on linear trend fit
#'
#' @param model an object of class \code{detrend}
#' @param newdata An optional idframe object in which to look for variables with
#' which to predict. If ommited, the original detrended idframe object is used
#'
#' @return an \code{idframe} object
#'
#' @examples
#' data(cstr)
#' train <- dataSlice(cstr,end=5000)
#' test <- dataSlice(cstr,start=6001)
#' fit <- detrend(train)
#' Ztrain <- predict(fit)
#' Ztest <- predict(fit,test)
#'
#' @export
predict.detrend <- function(model,newdata=NULL,...){
if(is.null(newdata)){
x <- fitted(model)
} else{
x <- newdata; reg <- time(x)
# checking if the original data has outputs
if(!is.null(model$output_trend)){
y <- ts(sapply(model$output_trend,predict,
newdata=data.frame(reg=reg)),
start=reg[1],end=tail(reg,n=1),deltat = deltat(x))
outputData(x) <- outputData(x) - y
outputNames(x) <- outputNames(newdata)
}
if(!is.null(model$input_trend)){
y <- ts(sapply(model$input_trend,predict,
newdata=data.frame(reg=reg)),
start=reg[1],end=tail(reg,n=1),deltat = deltat(x))
inputData(x) <- inputData(x) - y
inputNames(x) <- inputNames(newdata)
}
}
return(x)
}
#' Replace Missing Data by Interpolation
#'
#' Function for replacing missing values with interpolated ones. This is an
#' extension of the \code{na.approx} function from the \code{zoo} package.
#' The missing data is indicated using the value \emph{NA}.
#'
#' @param data an object of class \code{idframe}
#' @return
#' data (an idframe object) with missing data replaced.
#'
#' @seealso \code{\link[zoo]{na.approx}}
#'
#' @examples
#' data(cstr_mis)
#' summary(cstr_mis) # finding out the number of NAs
#' cstr <- misdata(cstr_mis)
#'
#' @importFrom zoo na.approx
#' @export
misdata <- function(data){
require(zoo)
f <- function(var,start,end,Ts){
time_range <- range(time(var))
start <- time_range[1];end <- time_range[2]
Ts <- deltat(var)
var <- ts(data=var,start=start,end=end,deltat=Ts)
out <- na.approx(var,na.rm=F)
return(as.numeric(out))
}
Z <- data
outputData(Z) <- apply(outputData(data),2,f)
inputData(Z) <- apply(inputData(data),2,f)
Z
}
#' Subset or Resample idframe data
#'
#' \code{dataSlice} is a subsetting method for objects of class \code{idframe}. It
#' extracts the subset of the object \code{data} observed between indices \code{start}
#' and \code{end}. If a frequency is specified, the series is then re-sampled at the
#' new frequency.
#'
#' @param data an object of class \code{idframe}
#' @param start the start index
#' @param end the end index
#' @param freq fraction of the original frequency at which the series
#' to be sampled.
#'
#' @details
#' The dataSlice function extends the \code{\link[stats]{window}}
#' function for idframe objects
#'
#' @return an idframe object
#'
#' @examples
#' data(cstr)
#' cstrsub <- dataSlice(cstr,start=200,end=400) # extract between indices 200 and 400
#' cstrTrain <- dataSlice(cstr,end=4500) # extract upto index 4500
#' cstrTest <- dataSlice(cstr,start=6501) # extract from index 6501 till the end
#' cstr_new <- dataSlice(cstr,freq=0.5) # resample data at half the original frequency
#'
#' @seealso \code{\link[stats]{window}}
#' @export
dataSlice <- function(data,start=NULL,end=NULL,freq=NULL){
# check if the class is correct
if(class(data)!='idframe')
stop("Not an idframe data")
indexWindow <- function(y,start,end,freq){
Y <- as.matrix(y); z <- as.vector(time(y))
Y <- window(Y,start=start,end=end,frequency=freq)
zw <- window(z,start=start,end=end,frequency=freq)
y <- ts(Y,start=zw[1],end=tail(zw,n=1),deltat=diff(zw)[1])
}
if(nOutputSeries(data)!=0)
outputData(data) <- indexWindow(outputData(data),start,end,freq)
if(nInputSeries(data)!=0)
inputData(data) <- indexWindow(inputData(data),start,end,freq)
return(data)
}
|
