1#
2#  This program is free software; you can redistribute it and/or modify
3#  it under the terms of the GNU General Public License as published by
4#  the Free Software Foundation; either version 2 of the License, or
5#  (at your option) any later version.
6#
7#  This program is distributed in the hope that it will be useful,
8#  but WITHOUT ANY WARRANTY; without even the implied warranty of
9#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10#  GNU General Public License for more details.
11#
12#  A copy of the GNU General Public License is available at
13#  ../../COPYING
14
15
16################################################################################
17# FUNCTION:              DESCRIPTION:
18#  applySeries           Applies a function to blocks of a 'timeSeries'
19#  fapply                Applies a function to 'timeSeries' windows
20# DEPRECATED:            DESCRIPTION:
21#  .applySeries           Applies a function to blocks of a 'timeSeries'
22#  .fapply                Applies a function to 'timeSeries' windows
23################################################################################
24
25
26applySeries <-
27    function(x, from = NULL, to = NULL, by = c("monthly", "quarterly"),
28    FUN = colMeans, units = NULL, format = x@format, zone = x@FinCenter,
29    FinCenter = x@FinCenter, recordIDs = data.frame(), title = x@title,
30    documentation = x@documentation, ...)
31{
32    # A function implemented by Diethelm Wuertz
33
34    # Description:
35    #   Apply a function to the margins of a 'timeSeries' object
36
37    # Details:
38    #   This function can be used to aggregate and coursen a
39    #   'timeSeries' object.
40
41    # Arguments:
42    #   x - a 'timeSeries' object to be aggregated
43    #   from, to - two 'timeDate' position vectors which size the
44    #       blocks
45    #   by - calendarical block, only active when both 'from'
46    #       and 'to' are NULL
47    #   FUN - function to be applied, by default 'colMeans'
48    #   units - a character vector with column names, allows to
49    #       overwrite the column names of the input 'timeSeries'
50    #       object.
51
52    # Value:
53    #   Returns a S4 object of class 'timeSeries'.
54
55    # Notes:
56    #   The size of the 'moving' window and the selection of an
57    #   'adj'-acent endpoint are not needed, all the information
58    #   is kept in the 'from' and 'to' position vectors.
59
60    # FUNCTION:
61
62    # .Deprecated("aggregate", "timeSeries")
63
64    # Check object:
65    if (!inherits(x, "timeSeries"))
66        stop("s is not a timeSeries object")
67
68    ###     if (x@format == "counts")
69    ###         stop(as.character(match.call())[1],
70    ###              " is for time series and not for signal series.")
71
72    # Monthly and Quarterly from and to:
73    if (is.null(from) & is.null(to)) {
74        if (by[1] == "monthly") {
75            # Use monthly blocks:
76            from = unique(timeFirstDayInMonth(time(x)))
77            to = unique(timeLastDayInMonth(time(x)))
78        } else if (by[1] == "quarterly") {
79            from = unique(timeFirstDayInQuarter(time(x)))
80            to = unique(timeLastDayInQuarter(time(x)))
81        } else {
82            stop("by must be eiter monthly or quarterly")
83        }
84        from@FinCenter = to@FinCenter = FinCenter
85    }
86
87    # Column Names:
88    colNames = units
89
90    # Function:
91    fun = match.fun(FUN)
92
93    ###     # Blocks:
94    ###     j.pos = as.POSIXct(time(x))
95    ###     j.from = as.POSIXct(from)
96    ###     j.to = as.POSIXct(to)
97
98    # Blocks:
99    j.pos = time(x)
100    if (is(j.pos, "timeDate")) {
101        j.from = as.timeDate(from)
102        j.to = as.timeDate(to)
103    } else {
104        j.from = as.integer(from)
105        j.to = as.integer(to)
106    }
107
108
109    # Iterate:
110    pos = time(x)
111    rowNames = rownames(x)
112    rowBind = NULL
113    for (i in seq_len(length(from))) {
114        test <- (j.pos >= j.from[i] & j.pos <= j.to[i])
115        if (!sum(test)) stop("outsite of range")
116        # make sure that cutted is a matrix ...
117        cutted = as.matrix(x[test, ])
118        # YC : *AND* make sure the matrix is not subbsetted to a vector!!!
119        # YC : here it is fine because as.matrix of a timeSeries checks it
120        # YC : but prefer to check it one more time at the end of the loop...
121        ### if (sum(test)>0) rownames(cutted) <- rowNames[test]
122        ans = fun(cutted, ...)
123        rowBind = rbind(rowBind, ans)
124    }
125    stopifnot(NCOL(rowBind) == NCOL(x)) # YC : see above
126    # YC : length(to) might not be == NCOL(rowBind)
127     if (length(as.character(to)) == NROW(rowBind))
128         rownames(rowBind) = as.character(to)
129
130    if (is.null(colNames)) {
131        units = x@units
132    } else {
133        units = colNames }
134
135    # Return Value:
136    timeSeries(data = rowBind,  units = units,
137        format = format, zone = zone, FinCenter = FinCenter, recordIDs =
138        recordIDs, title = title, documentation = documentation, ...)
139}
140
141
142# ------------------------------------------------------------------------------
143
144
145fapply <-
146function(x, from, to, FUN, ...)
147{
148    # .Deprecated("aggregate", "timeSeries")
149
150    # Check x:
151    stopifnot(is(x, "timeSeries"))
152    if (x@format == "counts")
153        stop(as.character(match.call())[1],
154             " is for time series and not for signal series.")
155
156    # Check for missing form/to:
157    if(missing(from)) from = start(x)
158    if(missing(to)) to = end(x)
159
160    # Return Value:
161    applySeries(x = x, from = from, to = to, FUN = FUN, ...)
162}
163
164
165################################################################################
166# *** OLD ***
167# Check if it is still used somewhere ...
168
169
170.applySeries <-
171    function (x, from = NULL, to = NULL, by = c("monthly", "quarterly"),
172    FUN = colMeans, units = NULL, ...)
173{
174    # Old/Alternative Version
175
176    # Chreck for 'timeSeries' Object:
177    stopifnot(is.timeSeries(x),
178              is(from, "timeDate") || is.null(from),
179              is(to,   "timeDate") || is.null(to))
180
181    # Allow for colMeans:
182    if (substitute(FUN) == "colMeans") FUN = "colAvgs"
183
184    # Monthly and Quarterly from and to:
185    if (is.null(from) & is.null(to)) {
186        by = match.arg(by)
187        if (by == "monthly") {
188            from = unique(timeFirstDayInMonth(time(x)))
189            to = unique(timeLastDayInMonth(time(x)))
190        }
191        else if (by == "quarterly") {
192            from = unique(timeFirstDayInQuarter(time(x)))
193            to = unique(timeLastDayInQuarter(time(x)))
194        }
195        from@FinCenter = to@FinCenter = x@FinCenter
196    }
197
198    # Start Cutting Process:
199    fun = match.fun(FUN)
200    cutted = NULL
201    i = 1
202
203    # Find First Interval which is not empty:
204    while (is.null(cutted)) {
205        cutted = cut(x, from[i], to[i])
206        if (!is.null(cutted)) {
207            # Non empty Interval:
208            ans = fun(cutted, ...)
209        }
210        i = i + 1
211    }
212    # Continue up to the end:
213    for (j in seq_len(length(from))) {
214        cutted = cut(x, from[j], to[j])
215        if (!is.null(cutted)) {
216            # Non empty Interval:
217            newAns = fun(cutted, ...)
218            ans = rbind(ans, newAns)
219        }
220    }
221
222    # Return Value:
223    ans
224}
225
226
227################################################################################
228# *** OLD ***
229# Check if it is still used somewhere ...
230
231
232.fapply <-
233function(x, from, to, FUN, ...)
234{
235    # A function implemented by Diethelm Wuertz
236
237    # Description:
238    #   Applies a function to 'timeSeries' windows
239
240    # Details:
241    #   This function can be used to aggregate and coursen a
242    #   'timeSeries' object.
243
244    # Arguments:
245    #   x - a 'timeSeries' object to be aggregated
246    #   from, to - two 'timeDate' position vectors which size the blocks
247    #   FUN - function to be applied, by default 'colMeans'
248
249    # Value:
250    #   Returns a S4 object of class 'timeSeries' if FUN returns
251    #   a time series object, otherwise a list, where the entries
252    #   for each window is the output of the function FUN.
253
254    # Notes:
255    #   The size of the 'moving' window and the selection of an
256    #   'adj'-acent endpoint are not needed, all the information
257    #   is kept in the 'from' and 'to' position vectors.
258
259    # FUNCTION:
260
261    # Check object:
262    if (!inherits(x, "timeSeries")) stop("s is not a timeSeries object")
263
264    # Monthly and Quarterly from and to:
265    if (is.null(from) & is.null(to)) {
266        if (by[1] == "monthly") {
267            # Use monthly blocks:
268            from = unique(timeFirstDayInMonth(time(x)))
269            to = unique(timeLastDayInMonth(time(x)))
270        } else if (by[1] == "quarterly") {
271            from = unique(timeFirstDayInQuarter(time(x)))
272            to = unique(timeLastDayInQuarter(time(x)))
273        } else {
274            stop("by must be eiter monthly or quarterly")
275        }
276        from@FinCenter = to@FinCenter = x@FinCenter
277    }
278
279    # Column Names:
280    colNames = units
281
282    # Function:
283    fun = match.fun(FUN)
284
285    # Blocks:
286    j.pos = as.POSIXct(time(x))
287    j.from = as.POSIXct(from)
288    j.to = as.POSIXct(to)
289
290    # Iterate:
291    y = series(x)
292    pos = time(x)
293    rowNames = rownames(x)
294
295    # Compute for the first window ...
296    i = 1
297    test = (j.pos >= j.from[i] & j.pos <= j.to[i])
298    # make sure that cutted is a matrix ...
299    cutted = as.matrix(y[test, ])
300    ### if (sum(test)>0) rownames(cutted) <- rowNames[test]
301    ans = fun(cutted, ...)
302
303    if (is.timeSeries(ans)) {
304        ## DW can this happen - check ?
305        rowBind = ans
306        for (i in 2L:length(from)) {
307            test = (j.pos >= j.from[1] & j.pos <= j.to[1])
308            # make sure that cutted is a matrix ...
309            cutted = as.matrix(y[test, ])
310            ### if (sum(test)>0) rownames(cutted) <- rowNames[test]
311            ans = fun(cutted, ...)
312            rowBind = rbind(rowBind, ans)
313        }
314        rownames(rowBind) = as.character(to)
315        if (is.null(colNames)) {
316            units = x@units
317        } else {
318            units = colNames
319        }
320        # Return Value:
321        ans = timeSeries(data = rowBind, charvec = as.character(to),
322            units = units, format = format, zone = x@zone, FinCenter =
323            x@FinCenter, recordIDs = x@recordIDs, title = x@title,
324            documentation = x@documentation, ...)
325        return(ans)
326    } else {
327        listBind = list()
328        ## DW [] -> [[]]
329        listBind[[1]] = ans
330        for (i in 2L:length(from)) {
331            test = (j.pos >= j.from[i] & j.pos <= j.to[i])
332            # make sure that cutted is a matrix ...
333            cutted = as.matrix(y[test, ])
334            ### if (sum(test)>0) rownames(cutted) <- rowNames[test]
335            ans = fun(cutted, ...)
336            ## DW [] -> [[]]
337            listBind[[i]] = ans
338        }
339        # Return Value:
340        ans = listBind
341        attr(ans, "control") <- list(x = x, from = from, to = to)
342        return(invisible(ans))
343    }
344
345    # Return Value:
346    return()
347}
348
349
350################################################################################
351