1
2# This R package is free software; you can redistribute it and/or
3# modify it under the terms of the GNU Library General Public
4# License as published by the Free Software Foundation; either
5# version 2 of the License, or (at your option) any later version.
6#
7# This R package 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 Library General Public License for more details.
11#
12# You should have received a copy of the GNU Library General
13# Public License along with this R package; if not, write to the
14# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
15# MA  02111-1307  USA
16
17
18################################################################################
19# MEHODS:                  SUBSETTING TIMEDATE OBJECTS:
20#  setMethod                Extracts/replaces subsets from 'timeDate' objects
21#                             signature   missing - missing - ANY
22#                             signature   numeric - missing - ANY
23#                             signature   logical - missing - ANY
24#                             signature   character - missing - ANY
25#                             signature   ANY - missing ANY
26# "[<-.timeDate"            Extracts/replaces subsets from 'timeDate' objects
27# FUNCTION:                DESCRIPTION:
28# .subsetCode               Defines codes for different types of subsettings
29# .subsetByPython           Subsets a 'timeDate' object by python like indexing
30# .subsetBySpan             Subsets a 'timeDate' object by span indexing
31################################################################################
32
33
34# Functions implemented by Yohan Chalabi and Diethelm Wuertz
35
36# ---------------------------------------------------------------------------- #
37# Roxygen Tags
38#' @export
39# ---------------------------------------------------------------------------- #
40setMethod("[", signature(x="timeDate", i="missing", j="missing", drop="ANY"),
41    function(x, i, j, ..., drop = TRUE) x)
42
43
44# ---------------------------------------------------------------------------- #
45# Roxygen Tags
46#' @export
47# ---------------------------------------------------------------------------- #
48setMethod("[", signature(x="timeDate", i="numeric", j="missing", drop="ANY"),
49    function(x, i, j, ..., drop = TRUE)
50    {
51        x@Data <- callGeneric(x@Data, i)
52        x
53    })
54
55
56# ---------------------------------------------------------------------------- #
57# Roxygen Tags
58#' @export
59# ---------------------------------------------------------------------------- #
60setMethod("[", signature(x="timeDate", i="logical", j="missing", drop="ANY"),
61    function(x, i, j, ..., drop = TRUE)
62    {
63        x@Data <- callGeneric(x@Data, i)
64        x
65    }
66)
67
68
69# ---------------------------------------------------------------------------- #
70# Roxygen Tags
71#' @export
72# ---------------------------------------------------------------------------- #
73setMethod("[", signature(x="timeDate", i="character", j="missing", drop="ANY"),
74    function(x, i, j, ..., drop = TRUE)
75    {
76        if (length(i) > 1) {
77            lt <- lapply(i, function(i, x) "["(x, i), x)
78            num <- unlist(lapply(lt, function(td) unclass(td@Data)))
79            return(timeDate(num, zone = "GMT", FinCenter = x@FinCenter))
80        }
81        if (.subsetCode(i) == "SPAN") {
82            # Subsetting by Span Indexing:
83            return(.subsetBySpan(x, i))
84        } else {
85            # Subsetting by Python Indexing:
86            return(.subsetByPython(x, i))
87        }
88    }
89)
90
91
92# ---------------------------------------------------------------------------- #
93# Roxygen Tags
94#' @export
95# ---------------------------------------------------------------------------- #
96setMethod("[", signature(x="timeDate", i="ANY", j="missing", drop="ANY"),
97          function(x, i, j, ..., drop = TRUE)
98          stop("Not Yet implemented"))
99
100
101# ---------------------------------------------------------------------------- #
102# Roxygen Tags
103#' @export
104# ---------------------------------------------------------------------------- #
105"[<-.timeDate" <-
106    function(x, ..., value)
107{
108    # A function implemented by Yohan Chalabi
109
110    # Description:
111    #   Extracts or replaces subsets from 'timeDate' objects
112
113    # Arguments:
114    #   x - a 'timeDate' object
115
116    # Value:
117    #   Returns a subset from a 'timeDate' object.
118
119    # FUNCTION:
120
121    FinCenter <- finCenter(x)
122
123    if (!inherits(value, "timeDate"))
124        value <- timeDate(value, zone = FinCenter, FinCenter = FinCenter)
125
126    # Subsets:
127    z <- as.POSIXlt(x)
128    value <- as.POSIXlt(value)
129    val <- "[<-"(z, ..., value=value)
130    val <- as.POSIXct(val)
131
132    # Return Value:
133    new("timeDate",
134        Data = val,
135        format = x@format,
136        FinCenter = FinCenter)
137}
138
139################################################################################
140
141# ---------------------------------------------------------------------------- #
142# Roxygen Tags
143#' @export
144# ---------------------------------------------------------------------------- #
145.subsetCode <-
146function(subset)
147{
148    # A function implemented by Diethelm Wuertz
149
150    # Description:
151    #   Defines codes for different types of subsettings
152
153    # Details:
154
155    # Python Like Indexing:
156    #   Subset:             Code:
157    #   ISO8601             00000
158    #   ::                  00010
159    #   ISO8601::ISO8601    00100
160    #   ISO8601::           01000
161    #   ::ISO8601           10000
162
163    # Indexing by Spans:
164    #   subsets = tolower(c(
165    #     "last 1 Month(s)",
166    #     "last 1 Week(s)",
167    #     "last 1 Day(s)",
168    #     "last 1 hour(s)",
169    #     "last 1 minute(s)",
170    #     "last 1 second(s)"))
171
172    # Example:
173    #   .subsetCode("2008-03::")
174    #   .subsetCode("last 2 Weeks")
175
176    # Code String:
177    if (length(grep("last", subset)) > 0 ) {
178        code = "SPAN"
179    } else {
180        code = paste(
181            sign(regexpr("^::[[:digit:]]", subset)[1]+1),
182            sign(regexpr("[[:digit:]]::$", subset)[1]+1),
183            sign(regexpr("[[:digit:]]::[[:digit:]]", subset)[1]+1),
184            as.integer(subset == "::"),
185            ## KH : "[a-Z]" is invalid in most locales
186            length(grep("[[:alpha:]]", subset)), sep = "")
187    }
188
189    # Return Value:
190    code
191}
192
193
194# ---------------------------------------------------------------------------- #
195# Roxygen Tags
196#' @export
197# ---------------------------------------------------------------------------- #
198.subsetByPython <-
199function(x = timeCalendar(), subset = "::")
200{
201    # A function implemented by Diethelm Wuertz
202
203    # Description:
204    #   Subsets a 'timeDate' object by python like indexing
205
206    # Arguments:
207    #   x - a timeDate object
208    #   subset - a python like subset string
209
210    # Example:
211    #   .subsetByPython(x, subset = "2008")
212    #   .subsetByPython(x, subset = "2008-07")
213    #   .subsetByPython(x, subset = "::")
214    #   .subsetByPython(x, subset = "2008-07::2008-09")
215    #   .subsetByPython(x, subset = "2008-07::")
216    #   .subsetByPython(x, subset = "::2008-06")
217
218    # FUNCTION:
219    stopifnot(length(subset) == 1)
220
221    # Subset Code:
222    code = .subsetCode(subset)
223
224    # Full Vector:
225    ans = x
226
227    # Date String:
228    date = strsplit(subset, "::")[[1]]
229
230    # 1. DATE
231    if(code == "00000") {
232        # should return NA if no match found
233        idx = grep(date, format(x))
234        if (!length(idx))
235            ans@Data <- as.POSIXct(NA)
236        else
237            ans <- x[idx]
238    }
239
240    # 2. ::
241    if(code == "00010") ans = x
242
243    # Internal Functions:
244    .completeStart = function(date) {
245        substr(paste0(date, "-01-01"), 1, 10) }
246    .completeEnd = function(date) {
247        if (nchar(date) == 4)
248            paste0(date, "-12-31") else
249        if (nchar(date) == 7)
250            format(timeLastDayInMonth(paste0(date, "-01"))) else
251        if (nchar(date) == 10)
252            date }
253
254    # 3. DATE::DATE:
255    if(code == "00100")
256        ans = window(x, .completeStart(date[1]), .completeEnd(date[2]))
257
258    # 4. DATE::
259    if(code == "01000")
260        ans = window(x, .completeStart(date[1]), end(x))
261
262    # 5. ::DATE
263    if(code == "10000")
264        ans = window(x, start(x), .completeEnd(date[2]))
265
266    # Return Value
267    ans
268}
269
270
271# ---------------------------------------------------------------------------- #
272# Roxygen Tags
273#' @export
274# ---------------------------------------------------------------------------- #
275.subsetBySpan  <-
276function(x = timeCalendar(), subset = "last 3 Months")
277{
278    # A function implemented by Diethelm Wuertz
279
280    # Description:
281    #   Subsets a 'timeDate' object by span indexing
282
283    # Arguments:
284    #   x - a timeDate object
285    #   subset - a span like subset string
286
287    # Note:
288    #   ye[ars]
289    #   mo[nths]
290    #   da[ys]
291    #   ho[urs]
292    #   mi[nutes]
293    #   se[conds]
294    #       ... only "last" spans are implemented
295
296    # Example:
297    #   .subsetBySpan(timeCalendar(), "last 2 months")
298    #   .subsetBySpan(timeCalendar(), "last 62 days")
299
300    # FUNCTION:
301    stopifnot(length(subset) == 1)
302
303    # Get Code:
304    code = .subsetCode(subset)
305    stopifnot(code == "SPAN")
306
307    # Settings:
308    duration = as.numeric(strsplit(subset, " ")[[1]][2])
309    len = c(ye = 31622400, mo = 2678400, da = 86400, ho = 3600, mi = 60, se = 1)
310    unit = tolower(substr(strsplit(subset, " ")[[1]][3], 1, 2))
311    offset = len[unit]*duration
312
313    # Return Value:
314    window(x, start = end(x) - offset, end(x))
315}
316
317
318################################################################################
319
320