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