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