Codebase list its / 6749c48
Import Debian changes 1.1.8-1 its (1.1.8-1) unstable; urgency=low * New upstream release * debian/control: Set (Build-)Depends: to current R version * debian/control: Set Standards-Version: to current version * debian/control: Changed Section: to 'gnu-r' Dirk Eddelbuettel 5 years ago
7 changed file(s) with 541 addition(s) and 425 deletion(s). Raw diff Collapse all Expand all
+10
-7
DESCRIPTION less more
00 Package: its
1 Version: 1.1.7
2 Date: 2006-09-09
3 Title: Irregular Time Series
4 Author: Portfolio & Risk Advisory Group, Commerzbank Securities
1 Version: 1.1.8
2 Date: 2009-09-06
3 Title: Irregular Time Series
4 Author: Portfolio & Risk Advisory Group, Commerzbank Securities
55 Maintainer: Whit Armstrong <armstrong.whit@gmail.com>
66 Depends: R (>= 2.0.0), methods, stats, Hmisc
7 Description: The its package contains an S4 class for handling irregular time series
7 Description: The its package contains an S4 class for handling
8 irregular time series
89 LazyLoad: yes
9 License: GPL Version 2
10 Packaged: Fri Jul 4 14:33:41 2008; whit
10 License: GPL-2
11 Packaged: 2009-09-06 18:42:50 UTC; whit
12 Repository: CRAN
13 Date/Publication: 2009-09-06 19:52:40
+68
-70
R/itspkg.R less more
5757
5858 ## add the data, taking the subset of the core for which the dates match
5959 ans <- callGeneric(e1[dates=i.dates,]@.Data,e2[dates=i.dates,]@.Data)
60
60
6161 ## make a new its w/ the ans and the dates intersection
6262 return(its(ans,i.dates))
6363 }
6464 setMethod("Arith",signature(e1="its",e2="its"),its.its.opp)
6565
6666 its.numeric.opp <- function(e1,e2) {
67 ans <- callGeneric(e1@.Data,e2)
67 ans <- callGeneric(e1@.Data,e2)
6868 return(its(ans,dates(e1)))
6969 }
7070 setMethod("Arith",signature("its", "numeric"),its.numeric.opp)
7171
7272 numeric.its.opp <- function(e1,e2) {
73 ans <- callGeneric(e1,e2@.Data)
73 ans <- callGeneric(e1,e2@.Data)
7474 return(its(ans,dates(e2)))
7575 }
7676 setMethod("Arith",signature("numeric","its"),numeric.its.opp)
7878 if(!isGeneric("plot")) setGeneric("plot", useAsDefault=plot)
7979
8080 plotIts <- function(x,y,colvec=1:ncol(x),type="l",ltypvec=1,lwdvec=1,
81 leg=FALSE,yrange,format,at,interp=c("linear","none"),lab=FALSE,...)
81 leg=FALSE,yrange,format,at,interp=c("linear","none"),lab=FALSE,...)
8282 {
8383 if(missing(yrange)){ylim <- range(x,na.rm=TRUE)} else {ylim <- yrange}
8484 interp <- match.arg(interp)
9292 lwdveclong <- rep(lwdvec,length.out=m)
9393 for(i in 1:m)
9494 {
95 if(interp=="linear")
95 if(interp=="linear")
9696 {
9797 vpoints <- c(1,which(!is.na(x[,i])),n)
9898 xxx <- x[,i]
115115 ...)
116116 }
117117 }
118 if(lab)
118 if(lab)
119119 {
120120 labcurve(curves=gencurves(x),
121121 labels=dimnames(x)[[2]],
132132 cex=.8)
133133 }
134134 grid()
135 axis.POSIXct(x=xdates[vpoints],side=1,at=at,format=format)
135 axis.POSIXct(x=xdates[vpoints],side=1,at=at,format=format)
136136 }
137137 setMethod("plot",signature(x="its",y="missing"),plotIts)
138138
206206 n <- length(alldates)
207207 m <- m1+m2
208208 united <- matrix(NA,nrow=n,ncol=m)
209 united[match(dates1,alldates),1:m1] <- x
210 united[match(dates2,alldates),(m1+1):m] <- y
209 if(m1>0) united[match(dates1,alldates),1:m1] <- x
210 if(m2>0) united[match(dates2,alldates),(m1+1):m] <- y
211211 result <- its(united,dates=alldates,names=allnames)
212212 }
213213 if(is.null(x)) {result <- y}
219219 setMethod("union",signature(x="NULL",y="its"),unionIts)
220220
221221 ##intersect-method---------------------------------------------------
222 intersectIts <- function(x,y)
223 {
224 if(!is.null(x)&!is.null(y))
225 {
226 dates1 <- x@dates
227 dates2 <- y@dates
228 alldates <- sort(intersect(dates1,dates2))
229 class(alldates) <- class(x@dates)
230 allnames <- c(dimnames(x)[[2]],dimnames(y)[[2]])
231 m1 <- dim(x)[2]
232 m2 <- dim(y)[2]
233 n <- length(alldates)
234 m <- m1+m2
235 united <- matrix(NA,n,m)
236 drows1 <- sort(match(dates1,alldates))
237 drows2 <- sort(match(dates2,alldates))
238 srows1 <- sort(match(alldates,dates1))
239 srows2 <- sort(match(alldates,dates2))
240 united[drows1,1:m1] <- x[srows1,,drop=FALSE]
241 united[drows2,(m1+1):m] <- y[srows2,,drop=FALSE]
242 result <- its(united,dates=alldates,names=allnames)
243 }
244 if(is.null(x)) {result <- y}
245 if(is.null(y)) {result <- x}
246 return(result)
222 intersectIts <- function(x,y) {
223 if( !is.null(x) & !is.null(y) ) {
224 dates1 <- x@dates
225 dates2 <- y@dates
226 alldates <- sort(intersect(dates1,dates2))
227 class(alldates) <- class(x@dates)
228 allnames <- c(dimnames(x)[[2]],dimnames(y)[[2]])
229 m1 <- dim(x)[2]
230 m2 <- dim(y)[2]
231 n <- length(alldates)
232 m <- m1+m2
233 united <- matrix(NA,n,m)
234 drows1 <- sort(match(dates1,alldates))
235 drows2 <- sort(match(dates2,alldates))
236 srows1 <- sort(match(alldates,dates1))
237 srows2 <- sort(match(alldates,dates2))
238 united[drows1,1:m1] <- x[srows1,,drop=FALSE]
239 united[drows2,(m1+1):m] <- y[srows2,,drop=FALSE]
240 result <- its(united,dates=alldates,names=allnames)
241 }
242 if(is.null(x)) {result <- y}
243 if(is.null(y)) {result <- x}
244 return(result)
247245 }
248246 setMethod("intersect",signature(x="its",y="its"),intersectIts)
249247 setMethod("intersect",signature(x="its",y="NULL"),intersectIts)
309307 dates=as.POSIXct(x=strptime(dimnames(x)[[1]],format=its.format())),
310308 names=dimnames(x)[[2]],format=its.format(),...)
311309 {
312
310
313311 if(!is(dates,"POSIXt")) stop("dates should be in POSIX format")
314
312
315313 dates <- as.POSIXct(dates)
316314
317315 ## fix identical bug
318316 if(is.null(attr(dates,"tzone"))) attr(dates,"tzone") <- ""
319
317
320318 if(is.null(dim(x))){dim(x) <- c(length(x),1)}
321319 x <- addDimnames(x)
322320 if(!(nrow(x)==length(dates))) {stop("dates length must match matrix nrows")}
358356 ##lagIts-function----------------------------------------------------
359357 lagIts <- function(x,k=1)
360358 {
361
359
362360 if (!inherits(x, "its")) stop("function is only valid for objects of class 'its'")
363
361
364362 lagmat <- core(x)*NA
365
363
366364 dimnames(lagmat)[[2]] <- paste(dimnames(lagmat)[[2]],"lag",k)
367
365
368366 n <- dim(x)[1]
369
367
370368 if(k>0) {
371369 lagmat[(k+1):n,] <- x[1:(n-k),]
372370 } else {
373371 lagmat[1:(n+k),] <- x[(1-k):n,]
374372 }
375
373
376374 y <- its(lagmat,dates=x@dates)
377
375
378376 return(y)
379377 }
380378
394392 }
395393
396394 ##alignedIts-function---------------------------------------------
397 alignedIts <- function(obj1,obj2,print=FALSE)
398 {
399 if (!inherits(obj1, "its")&inherits(obj2, "its")) stop("function is only valid for objects of class 'its'")
395 alignedIts <- function(obj1,obj2,print=FALSE) {
396 if( !inherits(obj1, "its") & inherits(obj2, "its") )
397 stop("function is only valid for objects of class 'its'")
398
400399 ##takes the intersection of the dates and extracts same dates for both
401400 mat <- intersectIts(obj1,obj2)
402401 obj1a <- mat[,1:ncol(obj1),drop=FALSE]
403402 obj2a <- mat[,(ncol(obj1)+1):ncol(mat),drop=FALSE]
404 if(print)
405 {
406 print(paste("inputs number of rows",nrow(obj1),nrow(obj2),"; output number of rows",nrow(mat)))
407 print(paste("inputs number of cols",ncol(obj1),ncol(obj2),"; output number of cols",ncol(obj1a),ncol(obj2a)))
408 }
409 return(list(obj1a,obj2a))
403 if(print) {
404 print(paste("inputs number of rows",nrow(obj1),nrow(obj2),"; output number of rows",nrow(mat)))
405 print(paste("inputs number of cols",ncol(obj1),ncol(obj2),"; output number of cols",ncol(obj1a),ncol(obj2a)))
406 }
407 list(obj1a,obj2a)
410408 }
411409
412410 ##appendIts-function-------------------------------------------------
493491 }
494492
495493 if(missing(end)) {
496 end <- format(as.Date(start,format=its.format())+9,format=its.format())
497 end.p <- as.POSIXct(x=strptime(end,format=format),tz=tz)
494 end <- format(as.Date(start,format=its.format()) + 99,format=its.format())
495 end.p <- as.POSIXct(x=strptime(end,format=format),tz=tz)
498496 } else if(mode(end)=="character") {
499 end.p <- as.POSIXct(x=strptime(end,format=format),tz=tz)
500 } else {
501 end.p <- as.POSIXct(end)
497 end.p <- as.POSIXct(x=strptime(end,format=format),tz=tz)
498 } else {
499 end.p <- as.POSIXct(end)
502500 }
503501
504502 dates <- seq(from=start.p,by=by,to=end.p)
510508 result <- its(matrix(x,ncol=ncol,nrow=length(dates)),dates)
511509
512510 return(result)
513 }
511 }
514512 ##extractIts-function-----------------------------------------------
515513 extractIts <- function(x,
516514 weekday=FALSE,
731729 outformat <- get(x=".itsformat",env=itsState,inherits=FALSE)
732730 } else {
733731 outformat <- formatDefault
734 assign(x=".itsformat",value=formatDefault,env=itsState,inherits=FALSE)
732 assign(x=".itsformat",value=formatDefault,env=itsState,inherits=FALSE)
735733 }
736734 return(outformat)
737735 }
794792 theperiod <- 100*theyear+theweek
795793 dayinperiod <- as.POSIXlt(dates[myindex1])$wday
796794 }
797
795
798796 ##2 if selecting based on 'find'
799797 if(find=="all") {
800798 myindex2 <- 1:length(myindex1)
842840 }
843841
844842 ##most.recent-function--------------------------------------------
845 most.recent <- function(x)
843 most.recent <- function(x)
846844 {
847845 ## return a vector of indices of the most recent TRUE value (thanks to Tony Plate)
848846 if (!is.logical(x)) stop("x must be logical")
871869 start, end,
872870 quote = c("Open","High", "Low", "Close"),
873871 provider = "yahoo",
874 method = "auto",
872 method = "auto",
875873 origin = "1899-12-30",
876874 compression="d",
877875 quiet=TRUE)
884882 stop("provider not implemented")
885883
886884 allinstruments <- NULL
887
888 if (missing(start))
885
886 if (missing(start))
889887 start <- "1991-01-02"
890 if (missing(end))
888 if (missing(end))
891889 end <- format(Sys.time() - 86400, "%Y-%m-%d")
892890
893891 provider <- match.arg(provider)
895893 end <- as.POSIXct(end, tz = "GMT")
896894
897895 for(i in 1:length(instruments)) {
898 url <- paste("http://chart.yahoo.com/table.csv?s=", instruments[i],
896 url <- paste("http://chart.yahoo.com/table.csv?s=", instruments[i],
899897 format(start, paste("&a=", as.character(as.numeric(format(start, "%m")) - 1), "&b=%d&c=%Y", sep = "")),
900898 format(end,paste("&d=", as.character(as.numeric(format(end,"%m")) - 1), "&e=%d&f=%Y", sep = "")),
901899 "&g=",compression,
915913 stop(paste("No data available for", instruments[i]))
916914 }
917915 data <- read.csv(destfile)
918 data <- data[nrow(data):1,] ## and inverse order in data
919 y <- its(as.matrix(data[,-1]),
920 dates=strptime(as.character(data[,1]), format="%Y-%m-%d"))
916 data <- data[nrow(data):1,] ## and inverse order in data
917 y <- its(as.matrix(data[,-1]),
918 dates=strptime(as.character(data[,1]), format="%Y-%m-%d"))
921919
922920 oneinstrument <- its(y)[,quote]
923921
+10
-0
debian/changelog less more
0 its (1.1.8-1) unstable; urgency=low
1
2 * New upstream release
3
4 * debian/control: Set (Build-)Depends: to current R version
5 * debian/control: Set Standards-Version: to current version
6 * debian/control: Changed Section: to 'gnu-r'
7
8 -- Dirk Eddelbuettel <edd@debian.org> Sun, 06 Sep 2009 16:25:29 -0500
9
010 its (1.1.7-1) unstable; urgency=low
111
212 * New upstream release
+4
-4
debian/control less more
00 Source: its
1 Section: math
1 Section: gnu-r
22 Priority: optional
33 Maintainer: Dirk Eddelbuettel <edd@debian.org>
4 Build-Depends-Indep: debhelper (>> 4.1.0), r-base-dev (>= 2.7.1), cdbs, r-cran-hmisc
5 Standards-Version: 3.8.0
4 Build-Depends: debhelper (>> 4.1.0), r-base-dev (>= 2.9.2), cdbs, r-cran-hmisc
5 Standards-Version: 3.8.3
66
77 Package: r-cran-its
88 Architecture: all
9 Depends: r-base-core (>= 2.7.1), r-cran-hmisc
9 Depends: r-base-core (>= 2.9.2), r-cran-hmisc
1010 Description: GNU R package for handling irregular time series
1111 This package contains an S4 class for handling irregular time series
+5
-1
inst/changes less more
00 its package release notes
1 1.1.8 2009-09-06
2 1 patch from Maxim Krikun to fix union w/ 0 column argument
3 2 testsuite cleanup
4 3 format cleanup for some functions
15
26 1.1.5 2006-09-09
37 1 added its,numeric and numeric,its S4 methods for Arith
6569 2 new 'lab' option in plot for labelling series
6670 3 'leg' option in plot now uses labcurve(), not locator()
6771 4 renamed the function classifications in documentation (itsFunctions, not its-functions)
68 5 dates() accessor & assignment methods for dates
72 5 dates() accessor & assignment methods for dates
6973 6 names() accessor & assignment functions for the dimnames(matrix)[[2]]
7074 7 core() accessor & assignment functions for the matrix
7175 8 revised summary()
+430
-329
inst/test/test.r less more
0 testIts <- function(graph=TRUE,New=TRUE)
1 {
2 addDimnames <- function(mat)
3 {
4 if(is.null(dimnames(mat))) {dimnames(mat) <- list(NULL,NULL)}
5 if(is.null(dimnames(mat)[[1]])&(nrow(mat)>0)) {dimnames(mat)[[1]] <- 1:nrow(mat)}
6 if(is.null(dimnames(mat)[[2]])&(ncol(mat)>0)) {dimnames(mat)[[2]] <- 1:ncol(mat)}
7 return(mat)
8 }
9 test <- function(x){if(!identical(x,TRUE))stop()}
10 ##test procedure for its
11 mytimes <- seq.POSIXt(from=Sys.time(),by=24*60*60,length.out=10)
12 attr(mytimes,"tzone") <- ""
13 mat <- addDimnames(matrix(1:30,10,3))
14 dimnames(mat)[[2]] <- c("A","B","C")
15 its.format("%Y-%m-%d %X")
16 x <- its(mat,mytimes)
17 moretimes <- seq.POSIXt(from=Sys.time()+1,by=24*60*60,length.out=11)
18 more <- addDimnames(matrix(1:33,11,3))
19 dimnames(more)[[2]] <- c("A","B","C")
20 x2 <- its(more,moretimes)
21 ##its-arith**********************************************************
22 ##arith-methods------------------------------------------------------
0 require(its)
1
2 addDimnames <- function(mat) {
3 if(is.null(dimnames(mat))) {dimnames(mat) <- list(NULL,NULL)}
4 if(is.null(dimnames(mat)[[1]])&(nrow(mat)>0)) {dimnames(mat)[[1]] <- 1:nrow(mat)}
5 if(is.null(dimnames(mat)[[2]])&(ncol(mat)>0)) {dimnames(mat)[[2]] <- 1:ncol(mat)}
6 return(mat)
7 }
8
9 test <- function(x) {
10 if(!x) stop()
11 }
12
13 today <- as.POSIXct(format(Sys.time(),"%Y-%m-%d"))
14 mytimes <- seq.POSIXt(from=today,by="DSTday",length.out=10)
15 attr(mytimes,"tzone") <- ""
16 mat <- addDimnames(matrix(1:30,10,3))
17 dimnames(mat)[[2]] <- c("A","B","C")
18 its.format("%Y-%m-%d")
19 x <- its(mat,mytimes)
20 moretimes <- seq.POSIXt(from=today+1,by="DSTday",length.out=11)
21 more <- addDimnames(matrix(1:33,11,3))
22 dimnames(more)[[2]] <- c("A","B","C")
23 x2 <- its(more,moretimes)
24
25
26 ##its-arith**********************************************************
27 ##arith-methods------------------------------------------------------
28 test.arith <- function() {
2329 y1 <- x[,1]+x[,2]
2430 y2 <- its(x@.Data[,1,drop=FALSE]+x@.Data[,2,drop=FALSE],mytimes)
2531 test(all.equal(y1@.Data,y2@.Data))
3238 y2 <- its(x@.Data[,1,drop=FALSE]+pi,mytimes)
3339 test(all.equal(y1@.Data,y2@.Data))
3440 test(all.equal(y1@dates,y2@dates))
35 y3 <- its(mat,mytimes+24*60*60)
36
37 ## changed in version 1.0.4
38 ## the intersection of the dates is now taken
39 ##ermsg <- try(x+y3,silent=TRUE)
40 ##test(ermsg=="Error in x + y3 : dates must match\n")
41 ##ermsg <- try(x+x2,silent=TRUE)
42 ##test(ermsg=="Error in x + x2 : dates must match\n")
43
44
45 ##extractor**********************************************************
41 }
42
43 ##extractor**********************************************************
44 test.extractor <- function() {
4645 y1 <- x[,1,dates=dates(x)[1:5]]
4746 y2 <- x[1:5,1]
4847 y3 <- y1+y2
4948 test(all(dates(y1)==dates(x)[1:5]))
5049 test(all(core(y1)==core(x)[1:5,1]))
51 ##names**************************************************************
50 }
51
52 ##names**************************************************************
53 test.names <- function() {
5254 test(all(names(x)==dimnames(core(x))[[2]]))
5355 y1 <- x
5456 names(y1) <- letters[1:ncol(y1)]
5557 test(all(names(y1)==letters[1:ncol(y1)]))
56 ##dates**************************************************************
58 }
59
60 ##dates**************************************************************
61 test.dates <- function() {
5762 test(all(dates(x)==x@dates))
5863 y1 <- x
5964 dates(y1) <- moretimes[1:nrow(y1)]
6065 test(all(dates(y1)==moretimes[1:nrow(y1)]))
61 ##core***************************************************************
66 }
67
68 ##core***************************************************************
69 test.core <- function() {
6270 test(all(core(x)==x@.Data))
6371 y1 <- x
6472 core(x) <- addDimnames(matrix(101:130,10,3))
6573 test(all(core(x)==addDimnames(matrix(101:130,10,3))))
66 ##its-cumdif*********************************************************
67 ##cumsum-method------------------------------------------------------
74 }
75
76 ##its-cumdif*********************************************************
77 ##cumsum-method------------------------------------------------------
78 test.cumsum <- function() {
6879 foo <- cumsum(x)
6980 test(all.equal(foo@.Data[,1],cumsum(x@.Data[,1])))
7081 test(all.equal(foo@dates,mytimes))
71 ##diff-method--------------------------------------------------------
82 }
83
84 ##diff-method--------------------------------------------------------
85 test.diff <- function() {
7286 foo <- diff(cumsum(x))
7387 bar <- alignedIts(foo,x,print=FALSE)
7488 test(all.equal(bar[[1]],bar[[2]]))
75 ##its-def************************************************************
76 ##-Functions-
77 ##is.its-function----------------------------------------------------
89 }
90
91 ##its-def************************************************************
92 ##-Functions-
93 ##is.its-function----------------------------------------------------
94 test.is.its <- function() {
7895 test(is.its(x))
7996 test(!is.its(x@.Data))
8097 test(!is.its(x@dates))
81 ##as.its-function----------------------------------------------------
98 }
99
100 ##as.its-function----------------------------------------------------
101 test.as.its <- function() {
82102 foo <- as.numeric(mat[,1,drop=F])
83103 class(foo) <- c("POSIXt","POSIXct")
84104 bar <- its(mat[,-1],foo)
85105 waz <- as.its(mat)
86106 test(all.equal(bar,waz))
87 ##its-function-------------------------------------------------------
88 x <- its(mat,mytimes)
107 }
108
109 ##its-function-------------------------------------------------------
110 test.its.creation <- function() {
89111 test(all.equal(x@dates,mytimes))
90112 test(all.equal(x@.Data/mat,x@.Data/x@.Data))
113
91114 ##parameters
92 years <- 100:105
93 hoursecs <- 60*60
94 regdaysecs <- 24*hoursecs
95 monthdays <- c(28,29,30,31)
96 monthsecs <- c(monthdays*regdaysecs,monthdays*regdaysecs-hoursecs,monthdays*regdaysecs+hoursecs)
97 weeksecs <- 7*regdaysecs ##+hoursecs*c(-1,0,1)
98 daysecs <- regdaysecs+hoursecs*c(-1,0,1)
115 ## years <- 100:105
116 ## hoursecs <- 60*60
117 ## regdaysecs <- 24*hoursecs
118 ## monthdays <- c(28,29,30,31)
119 ## monthsecs <- c(monthdays*regdaysecs,monthdays*regdaysecs-hoursecs,monthdays*regdaysecs+hoursecs)
120 ## weeksecs <- 7*regdaysecs ##+hoursecs*c(-1,0,1)
121 ## daysecs <- regdaysecs+hoursecs*c(-1,0,1)
122 ## its.format("%Y-%m-%d")
123 }
124
125 ##***newIts
126 ##newIts-from
127 test.new.its <- function() {
99128 its.format("%Y-%m-%d")
100
101 ##***newIts
102 ##newIts-from
103 if(as.numeric(R.Version()$major)*1000+as.numeric(R.Version()$minor)*10>=1080 & New)
104 {
105
106 mystarts <- c("2003-01-01","2002-12-31","2003-11-17","2004-10-27")
107 myends <- c("2003-02-01","2003-12-31","2004-12-17","2004-11-01")
108
109 for(ddd in mystarts)
110 {
111 TEST <- newIts(start=ddd)
112 test(start(TEST)==ddd)
113 }
114 ##newIts-to
115 for(ddd in myends)
116 {
117 TEST <- newIts(start="2002-11-17",end=ddd)
118 test(end(TEST)==ddd)
119 }
120 for(i in 1:3)
121 {
122 TEST <- newIts(start=mystarts[i],end=myends[i])
123 test((start(TEST)==mystarts[i])&(end(TEST)==myends[i]))
124 }
125
126 ##newIts-by
127 now <- Sys.time()
128 its.end.date <- now+100*24*60*60
129 TEST <- newIts(end=format(its.end.date,"%Y-%m-%d"))
130 test(all(diff(as.numeric(TEST@dates))%in%daysecs))
131 TEST <- newIts(start="2003-10-1",end="2010-12-1",by="month")
132 test(all(diff(as.numeric(TEST@dates))%in%monthsecs))
133 ##(n.b. no DSTweek available)
134 TEST <- newIts(end=format(its.end.date,"%Y-%m-%d"),by="week")
135 test(all(diff(as.numeric(TEST@dates))%in%weeksecs))
136
137
138 ##newIts-ncol
139 ncol(newIts(end=format(its.end.date,"%Y-%m-%d"),ncol=5))==5
140
141 ##***extractIts permutations
142 ##-weekday
143 weekDaySelection <- c(0,6)
144 nowt <- newIts(extract=TRUE,weekday=TRUE,select=weekDaySelection)
145 test(length(nowt)==0)
146 weekDaySelection <- 1:5
147 TEST1 <- newIts(extract=TRUE,weekday=TRUE)
148 TEST2 <- newIts(extract=TRUE,weekday=TRUE,select=weekDaySelection)
149 TEST3 <- newIts()
150 test(length(TEST1)>0)
151 test(length(TEST2)==length(TEST1))
152 test(length(TEST3)>length(TEST2))
153 test(all(as.POSIXlt(TEST1@dates)$wday%in%weekDaySelection))
154 test(all(weekDaySelection%in%as.POSIXlt(TEST1@dates)$wday))
155 ##-find ("all","last","first")
156 test(identical(newIts(extract=TRUE,select=0:6,period="week"),newIts()))
157 test(identical(newIts(extract=TRUE,select=0:6,period="week",find="all"),newIts()))
158 TEST1 <- newIts(extract=TRUE,period="week",find="first",partial=FALSE)
159 TEST2 <- newIts(extract=TRUE,select=0,period="week")
160 test(all(TEST1%in%TEST2))
161 TEST1 <- newIts(extract=TRUE,period="week",find="last",partial=FALSE)
162 TEST2 <- newIts(extract=TRUE,select=6,period="week")
163 test(all(TEST1%in%TEST2))
164 TEST1 <- newIts(weekday=TRUE,extract=TRUE,period="week",find="first",partial=FALSE)
165 TEST2 <- newIts(weekday=TRUE,extract=TRUE,select=1,period="week")
166 test(all(TEST1%in%TEST2))
167 TEST1 <- newIts(weekday=TRUE,extract=TRUE,period="week",find="last",partial=FALSE)
168 TEST2 <- newIts(weekday=TRUE,extract=TRUE,select=5,period="week")
169 test(all(TEST1%in%TEST2))
170 ##-period
171 test(all(as.POSIXlt(newIts(extract=TRUE,period="week",find="first",partial=FALSE)@dates)$wday==0))
172 test(all(as.POSIXlt(newIts(extract=TRUE,period="week",find="last",partial=FALSE)@dates)$wday==6))
173 test(all(as.POSIXlt(newIts(extract=TRUE,period="month",find="first",partial=FALSE)@dates)$mday==1))
174 test(all(as.POSIXlt(newIts(extract=TRUE,period="month",find="last",partial=FALSE)@dates)$mday%in%28:31))
175 test(identical(newIts(extract=TRUE,period="week",select=0:6),newIts()))
176 test(identical(newIts(extract=TRUE,period="month",select=1:31),newIts()))
177 ##-partials
178 TEST <- newIts(start="2003-11-18")
179 TEST1 <- newIts(start="2003-11-18",period="week",find="first",extract=TRUE,partial=TRUE)
180 TEST2 <- newIts(start="2003-11-18",period="week",find="first",extract=TRUE,partial=FALSE)
181 TEST@dates[1]==TEST1@dates[1]
182 test((nrow(TEST1)-1)==nrow(TEST2))
183 ##-select
184 for(i in 0:6)
185 {
186 TEST <- newIts(extract=TRUE,period="week",select=i)
187 test(all(as.POSIXlt(TEST@dates)$wday==i))
188 }
189 for(i in 30:31)
190 {
191 TEST <- newIts(extract=TRUE,period="month",select=i)
192 test(all(as.POSIXlt(TEST@dates)$mday==i))
193 }
194 }
195 ##its-disp***********************************************************
196 ##plot-method--------------------------------------------------------
197 ##create 5 sinusoids differing in phase by pi/6
129 mystarts <- c("2003-01-01","2002-12-31","2003-11-17","2004-10-27")
130 myends <- c("2003-02-01","2003-12-31","2004-12-17","2004-11-01")
131
132 for(ddd in mystarts) {
133 TEST <- newIts(start=ddd)
134 test(start(TEST)==ddd)
135 }
136
137 ##newIts-to
138 for(ddd in myends) {
139 TEST <- newIts(start="2002-11-17",end=ddd)
140 test(end(TEST)==ddd)
141 }
142
143 for(i in 1:3) {
144 TEST <- newIts(start=mystarts[i],end=myends[i])
145 test((start(TEST)==mystarts[i])&(end(TEST)==myends[i]))
146 }
147
148 ##newIts-by
149 now <- as.POSIXct(format(Sys.time(),"%Y-%m-%d"))
150 its.end.date <- now+100*24*60*60
151
152 day.range <- seq.POSIXt(from=now,to=its.end.date,by="DSTday")
153 TEST <- newIts(end=format(its.end.date,"%Y-%m-%d"))
154 test(all.equal(day.range,TEST@dates))
155
156 month.range <- seq.POSIXt(from=as.POSIXct("2003-10-01"),to=as.POSIXct("2010-12-01"),by="months")
157 TEST <- newIts(start="2003-10-01",end="2010-12-01",by="month")
158 test(all.equal(month.range,TEST@dates))
159
160 week.range <- seq.POSIXt(from=now,to=its.end.date,by="weeks")
161 TEST <- newIts(end=format(its.end.date,"%Y-%m-%d"),by="week")
162 test(all.equal(week.range,TEST@dates))
163
164 ##newIts-ncol
165 ncol(newIts(end=format(its.end.date,"%Y-%m-%d"),ncol=5))==5
166
167 ##***extractIts permutations
168 ##-weekday
169 weekDaySelection <- c(0,6)
170 nowt <- newIts(extract=TRUE,weekday=TRUE,select=weekDaySelection)
171 test(length(nowt)==0)
172 weekDaySelection <- 1:5
173 TEST1 <- newIts(extract=TRUE,weekday=TRUE)
174 TEST2 <- newIts(extract=TRUE,weekday=TRUE,select=weekDaySelection)
175 TEST3 <- newIts()
176 test(length(TEST1)>0)
177 test(length(TEST2)==length(TEST1))
178 test(length(TEST3)>length(TEST2))
179 test(all(as.POSIXlt(TEST1@dates)$wday%in%weekDaySelection))
180 test(all(weekDaySelection%in%as.POSIXlt(TEST1@dates)$wday))
181
182 ##-find ("all","last","first")
183 test(identical(newIts(extract=TRUE,select=0:6,period="week"),newIts()))
184 test(identical(newIts(extract=TRUE,select=0:6,period="week",find="all"),newIts()))
185 TEST1 <- newIts(extract=TRUE,period="week",find="first",partial=FALSE)
186 TEST2 <- newIts(extract=TRUE,select=0,period="week")
187 test(all(TEST1%in%TEST2))
188 TEST1 <- newIts(extract=TRUE,period="week",find="last",partial=FALSE)
189 TEST2 <- newIts(extract=TRUE,select=6,period="week")
190 test(all(TEST1%in%TEST2))
191 TEST1 <- newIts(weekday=TRUE,extract=TRUE,period="week",find="first",partial=FALSE)
192 TEST2 <- newIts(weekday=TRUE,extract=TRUE,select=1,period="week")
193 test(all(TEST1%in%TEST2))
194 TEST1 <- newIts(weekday=TRUE,extract=TRUE,period="week",find="last",partial=FALSE)
195 TEST2 <- newIts(weekday=TRUE,extract=TRUE,select=5,period="week")
196 test(all(TEST1%in%TEST2))
197
198 ##-period
199 test(all(as.POSIXlt(newIts(extract=TRUE,period="week",find="first",partial=FALSE)@dates)$wday==0))
200 test(all(as.POSIXlt(newIts(extract=TRUE,period="week",find="last",partial=FALSE)@dates)$wday==6))
201 test(all(as.POSIXlt(newIts(extract=TRUE,period="month",find="first",partial=FALSE)@dates)$mday==1))
202 test(all(as.POSIXlt(newIts(extract=TRUE,period="month",find="last",partial=FALSE)@dates)$mday%in%28:31))
203 test(identical(newIts(extract=TRUE,period="week",select=0:6),newIts()))
204 test(identical(newIts(extract=TRUE,period="month",select=1:31),newIts()))
205
206 ##-partials
207 TEST <- newIts(start="2003-11-18")
208 TEST1 <- newIts(start="2003-11-18",period="week",find="first",extract=TRUE,partial=TRUE)
209 TEST2 <- newIts(start="2003-11-18",period="week",find="first",extract=TRUE,partial=FALSE)
210 TEST@dates[1]==TEST1@dates[1]
211 test((nrow(TEST1)-1)==nrow(TEST2))
212
213 ##-select
214 for(i in 0:6) {
215 TEST <- newIts(extract=TRUE,period="week",select=i)
216 test(all(as.POSIXlt(TEST@dates)$wday==i))
217 }
218
219 for(i in 30:31) {
220 TEST <- newIts(extract=TRUE,period="month",select=i)
221 test(all(as.POSIXlt(TEST@dates)$mday==i))
222 }
223 }
224
225 ##its-disp***********************************************************
226 ##plot-method--------------------------------------------------------
227 ##create 5 sinusoids differing in phase by pi/6
228 test.plot.its <- function() {
198229 its.format("%Y-%m-%d %X")
199 if(graph)
200 {
201 sintimes <- seq.POSIXt(from=Sys.time(),by=24*60*60,length.out=100)
202 sintimes.num <- as.numeric(sintimes)
203 sinmat <- addDimnames(matrix(NA,100,5))
204 for(j in 1:5){sinmat[,j] <- sin((6*pi*sintimes.num/(sintimes.num[100]-sintimes.num[1]))-j*pi/6)}
205 dimnames(sinmat)[[2]] <- LETTERS[1:5]
206 sinx <- its(sinmat,sintimes)
207 par(mfrow=c(3,3))
208 ##line,point
209 plot(sinx,type="p",main="Point")
210 plot(sinx,type="l",main="Line")
211 plot(sinx,type="b",main="Both")
212 ##colour, width, type cycling
213 plot(sinx,lwdvec=1:3,main="Width")
214 plot(sinx,ltypvec=1:3,main="Type")
215 plot(sinx,colvec=c(1,2,7),main="Colour")
216 ##axis
217 plot(sinx,format="%B",main="Label")
218 plot(sinx,at=sintimes[c(1,100)],main="Position")
219 ##NA handling
220 sinx[10:20,] <- sinx[10:20,]*NA
221 sinx[,2] <- sinx[,2]*NA
222 plot(sinx,interp="n",main="NAs")
223 }
224 ##print-method-------------------------------------------------------
225 print(x)
226 ##its-file***********************************************************
227 ##writecsvIts-function-----------------------------------------------
230 sintimes <- seq.POSIXt(from=Sys.time(),by=24*60*60,length.out=100)
231 sintimes.num <- as.numeric(sintimes)
232 sinmat <- addDimnames(matrix(NA,100,5))
233 for(j in 1:5){sinmat[,j] <- sin((6*pi*sintimes.num/(sintimes.num[100]-sintimes.num[1]))-j*pi/6)}
234 dimnames(sinmat)[[2]] <- LETTERS[1:5]
235 sinx <- its(sinmat,sintimes)
236 par(mfrow=c(3,3))
237 ##line,point
238 plot(sinx,type="p",main="Point")
239 plot(sinx,type="l",main="Line")
240 plot(sinx,type="b",main="Both")
241 ##colour, width, type cycling
242 plot(sinx,lwdvec=1:3,main="Width")
243 plot(sinx,ltypvec=1:3,main="Type")
244 plot(sinx,colvec=c(1,2,7),main="Colour")
245 ##axis
246 plot(sinx,format="%B",main="Label")
247 plot(sinx,at=sintimes[c(1,100)],main="Position")
248 ##NA handling
249 sinx[10:20,] <- sinx[10:20,]*NA
250 sinx[,2] <- sinx[,2]*NA
251 plot(sinx,interp="n",main="NAs")
252 }
253
254 ##print-method-------------------------------------------------------
255 print(x)
256 ##its-file***********************************************************
257 ##writecsvIts-function-----------------------------------------------
258 test.read.write.its <- function() {
228259 file <- tempfile()
229260 writecsvIts(x,file,col.names=FALSE)
230261 writecsvIts(x,file,row.names=FALSE,col.names=FALSE)
232263 ##readcsvIts-function------------------------------------------------
233264 foo <- its(readcsvIts(file))
234265 y <- its(x)
235 test(all.equal(foo,y))
236266 test(identical(as.numeric(foo@.Data),as.numeric(y@.Data)))
237 test(identical(foo@dates,y@dates))
267 test(all.equal(foo@dates,y@dates))
238268 test(identical(dimnames(foo),dimnames(y)))
239 ##its-fin************************************************************
240 ##accrueIts-function-------------------------------------------------
241 test(all.equal(accrueIts(x)-lagIts(x)[-1,]/(365),accrueIts(x)*0))
242 ##its-info***********************************************************
243 ##summary-method-----------------------------------------------------
269 }
270
271 ##its-fin************************************************************
272 ##accrueIts-function-------------------------------------------------
273 ##test(all.equal(accrueIts(x)-lagIts(x)[-1,]/(365),accrueIts(x)*0))
274 ##its-info***********************************************************
275 ##summary-method-----------------------------------------------------
276 test.its.summary <- function() {
244277 foo <- summary(x)
245278 test(all.equal(as.numeric(foo[1,]),seq(1,21,10)))
246279 test(all.equal(as.numeric(foo[6,]),seq(10,30,10)))
247280 test(all.equal(as.numeric(foo[8,]),rep(10,3)))
248 ##start-method-------------------------------------------------------
281 }
282
283 ##start-method-------------------------------------------------------
284 test.its.start <- function() {
249285 test(identical(start(x,format="%Y-%m-%d-%X"),format.POSIXct(mytimes[1],format="%Y-%m-%d-%X")))
250286 test(identical(start(x[2:nrow(x),],format="%Y-%m-%d-%X"),format.POSIXct(mytimes[2],format="%Y-%m-%d-%X")))
251 ##end -method--------------------------------------------------------
287 }
288
289 ##end -method--------------------------------------------------------
290 test.its.end <- function() {
252291 test(identical(end(x,format="%Y-%m-%d %X"),format.POSIXct(mytimes[10],format="%Y-%m-%d %X")))
253292 test(identical(end(x[1:(nrow(x)-1),],format="%Y-%m-%d %X"),format.POSIXct(mytimes[nrow(x)-1],format="%Y-%m-%d %X")))
254 ##its-join***********************************************************
255 ##alignedIts-function---------------------------------------------
293 }
294 ##its-join***********************************************************
295 ##alignedIts-function---------------------------------------------
296 test.aligned.its <- function() {
297 its.format("%Y-%m-%d")
256298 isub <- seq(1,9,2)
257 x <- its(x)
258299 xsub <- x[isub,]
259300 foo <- alignedIts(x,xsub,print=F)
260301
264305
265306 test(identical(foo[[1]]@dates,xsub@dates))
266307 test(identical(core(foo[[1]]),core(xsub)))
267
268 ##appendIts-function-------------------------------------------------
269
308 }
309
310 ##appendIts-function-------------------------------------------------
311 test.append.its <- function() {
312 its.format("%Y-%m-%d %X")
313 xx <- its(mat,mytimes)
270314 ## these operations change the order of the attributes of the date
271315 ## after this, identical can't be used to compare series
272316 ## because the attributes order does not match
273317 later <- mytimes+366*24*60*60
274318 over <- mytimes+5*24*60*60
275319
276
277 x <- its(mat,mytimes)
278320 xlate <- its(mat,later)
279321 xover <- its(mat,over)
280322
281 foo <- appendIts(x,xlate)
282 bar <- appendIts(xlate,x)
323 foo <- appendIts(xx,xlate)
324 bar <- appendIts(xlate,xx)
283325 test(all.equal(foo,bar))
284 test(all.equal(foo[1:10],x))
326 test(all.equal(foo[1:10],xx))
285327 ## test(identical(foo[11:20],xlate))
286328 test(all.equal(foo[11:20],xlate))
287 foo <- try(appendIts(x,x[(2:(nrow(x)-1)),],but=FALSE),silent=TRUE)
329 foo <- try(appendIts(x,xx[(2:(nrow(x)-1)),],but=FALSE),silent=TRUE)
288330 test(identical(grep("appendor data must extend appendee data",foo)>0,TRUE))
289331 foo <- try(appendIts(x,xover,but=FALSE),silent=TRUE)
290332 test(identical(grep("overlap data does not match",foo)>0,TRUE))
293335 dimnames(xlate)[[2]][1] <- "Z"
294336 foo <- try(appendIts(x,xlate),silent=TRUE)
295337 test(foo=="Error in appendIts(x, xlate) : names of the two inputs must match\n")
296 ##10 cases
338 ##10 cases
297339 ## S1 E1 S2 E2
298340 ## 1 1 2 3 4
299341 ## 2 1 3 2 4
305347 ## 8 1 2 3 3
306348 ## 9 2 3 1 1
307349 ##10 1 2 1 1
308 x <- its(mat,mytimes)
350
309351 ## 1 1 2 3 4
310 x1 <- x[1:4,]
311 x2 <- x[5:8,]
312 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
313 test(identical(x[1:8,],foo))
314 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
315 test(identical(x[1:8,],foo))
352 x1 <- xx[1:4,]
353 x2 <- xx[5:8,]
354 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
355 test(identical(xx[1:8,],foo))
356 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
357 test(identical(xx[1:8,],foo))
316358 foo <- appendIts(x1,x2,but=TRUE,matchnames=FALSE)
317 test(identical(x[1:8,],foo))
359 test(identical(xx[1:8,],foo))
318360 foo <- appendIts(x1,x2,but=TRUE,matchnames=TRUE)
319 test(identical(x[1:8,],foo))
361 test(identical(xx[1:8,],foo))
320362 ## 2 1 3 2 4
321 x1 <- x[1:4,]
322 x2 <- x[3:6,]
323 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
324 test(identical(x[1:6,],foo))
325 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
326 test(identical(x[1:6,],foo))
363 x1 <- xx[1:4,]
364 x2 <- xx[3:6,]
365 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
366 test(identical(xx[1:6,],foo))
367 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
368 test(identical(xx[1:6,],foo))
327369 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=FALSE),silent=TRUE)
328370 test(identical(grep("overlap not allowed",foo)>0,TRUE))
329371 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=TRUE),silent=TRUE)
330372 test(identical(grep("overlap not allowed",foo)>0,TRUE))
331373 ## 3 1 4 2 3
332 x1 <- x[1:4,]
333 x2 <- x[2:3,]
374 x1 <- xx[1:4,]
375 x2 <- xx[2:3,]
334376 foo <- try(appendIts(x1,x2,but=FALSE,matchnames=FALSE),silent=TRUE)
335377 test(identical(grep("appendor data must extend appendee data",foo)>0,TRUE))
336378 foo <- try(appendIts(x1,x2,but=FALSE,matchnames=TRUE),silent=TRUE)
340382 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=TRUE),silent=TRUE)
341383 test(identical(grep("overlap not allowed",foo)>0,TRUE))
342384 ## 4 2 3 1 4
343 x1 <- x[2:3,]
344 x2 <- x[1:4,]
385 x1 <- xx[2:3,]
386 x2 <- xx[1:4,]
345387 foo <- try(appendIts(x1,x2,but=FALSE,matchnames=FALSE),silent=TRUE)
346388 test(identical(grep("appendor data must extend appendee data",foo)>0,TRUE))
347389 foo <- try(appendIts(x1,x2,but=FALSE,matchnames=TRUE),silent=TRUE)
351393 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=TRUE),silent=TRUE)
352394 test(identical(grep("overlap not allowed",foo)>0,TRUE))
353395 ## 5 2 4 1 3
354 x1 <- x[2:4,]
355 x2 <- x[1:3,]
356 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
357 test(identical(x[1:4,],foo))
358 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
359 test(identical(x[1:4,],foo))
396 x1 <- xx[2:4,]
397 x2 <- xx[1:3,]
398 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
399 test(identical(xx[1:4,],foo))
400 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
401 test(identical(xx[1:4,],foo))
360402 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=FALSE),silent=TRUE)
361403 test(identical(grep("overlap not allowed",foo)>0,TRUE))
362404 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=TRUE),silent=TRUE)
363405 test(identical(grep("overlap not allowed",foo)>0,TRUE))
364406 ## 6 3 4 1 2
365 x1 <- x[3:4,]
366 x2 <- x[1:2,]
367 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
368 test(identical(x[1:4,],foo))
369 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
370 test(identical(x[1:4,],foo))
407 x1 <- xx[3:4,]
408 x2 <- xx[1:2,]
409 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
410 test(identical(xx[1:4,],foo))
411 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
412 test(identical(xx[1:4,],foo))
371413 foo <- appendIts(x1,x2,but=TRUE,matchnames=FALSE)
372 test(identical(x[1:4,],foo))
414 test(identical(xx[1:4,],foo))
373415 foo <- appendIts(x1,x2,but=TRUE,matchnames=TRUE)
374 test(identical(x[1:4,],foo))
416 test(identical(xx[1:4,],foo))
375417 ## 7 1 2 2 2
376 x1 <- x[1:4,]
377 x2 <- x[4,]
378 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
379 test(identical(x[1:4,],foo))
380 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
381 test(identical(x[1:4,],foo))
418 x1 <- xx[1:4,]
419 x2 <- xx[4,]
420 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
421 test(identical(xx[1:4,],foo))
422 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
423 test(identical(xx[1:4,],foo))
382424 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=FALSE),silent=TRUE)
383425 test(identical(grep("overlap not allowed",foo)>0,TRUE))
384426 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=TRUE),silent=TRUE)
385427 test(identical(grep("overlap not allowed",foo)>0,TRUE))
386428 ## 8 1 2 3 3
387 x1 <- x[1:4,]
388 x2 <- x[5,]
389 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
390 test(identical(x[1:5,],foo))
391 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
392 test(identical(x[1:5,],foo))
429 x1 <- xx[1:4,]
430 x2 <- xx[5,]
431 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
432 test(identical(xx[1:5,],foo))
433 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
434 test(identical(xx[1:5,],foo))
393435 foo <- appendIts(x1,x2,but=TRUE,matchnames=FALSE)
394 test(identical(x[1:5,],foo))
436 test(identical(xx[1:5,],foo))
395437 foo <- appendIts(x1,x2,but=TRUE,matchnames=TRUE)
396 test(identical(x[1:5,],foo))
438 test(identical(xx[1:5,],foo))
397439 ## 9 2 3 1 1
398 x1 <- x[2:4,]
399 x2 <- x[1,]
400 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
401 test(identical(x[1:4,],foo))
402 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
403 test(identical(x[1:4,],foo))
440 x1 <- xx[2:4,]
441 x2 <- xx[1,]
442 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
443 test(identical(xx[1:4,],foo))
444 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
445 test(identical(xx[1:4,],foo))
404446 foo <- appendIts(x1,x2,but=TRUE,matchnames=FALSE)
405 test(identical(x[1:4,],foo))
447 test(identical(xx[1:4,],foo))
406448 foo <- appendIts(x1,x2,but=TRUE,matchnames=TRUE)
407 test(identical(x[1:4,],foo))
449 test(identical(xx[1:4,],foo))
408450 ##10 1 2 1 1
409 x1 <- x[2:4,]
410 x2 <- x[2,]
411 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
412 test(identical(x[2:4,],foo))
413 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
414 test(identical(x[2:4,],foo))
451 x1 <- xx[2:4,]
452 x2 <- xx[2,]
453 foo <- appendIts(x1,x2,but=FALSE,matchnames=FALSE)
454 test(identical(xx[2:4,],foo))
455 foo <- appendIts(x1,x2,but=FALSE,matchnames=TRUE)
456 test(identical(xx[2:4,],foo))
415457 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=FALSE),silent=TRUE)
416458 test(identical(grep("overlap not allowed",foo)>0,TRUE))
417459 foo <- try(appendIts(x1,x2,but=TRUE,matchnames=TRUE),silent=TRUE)
418460 test(identical(grep("overlap not allowed",foo)>0,TRUE))
419 ##union-method-------------------------------------------------------
461 }
462
463 ##union-method-------------------------------------------------------
464 test.union.its <- function() {
465 its.format("%Y-%m-%d")
420466 isub <- seq(1,9,2)
421467 ioth <- setdiff(1:10,isub)
422468 xsub <- x[isub,]
424470 test(identical(xun[,1:3],x))
425471 test(identical(xun[isub,4:6],xsub))
426472 test(all(is.na(xun[ioth,4:6])))
427 ##intersect-method---------------------------------------------------
473 }
474
475 ##intersect-method---------------------------------------------------
476 test.intersect.its <- function() {
477 its.format("%Y-%m-%d")
478 isub <- seq(1,9,2)
428479 xsub <- x[isub,]
429480 xin <- intersect(x,xsub)
430481 test(identical(xin[,1:3],xsub))
431482 test(identical(xin[,4:6],xsub))
432 ##its-lags***********************************************************
433 ##lagIts-function----------------------------------------------------
483 }
484
485 ##its-lags***********************************************************
486 ##lagIts-function----------------------------------------------------
487 test.lag.its <- function() {
434488 foo <- lagIts(x)
435489 test(all(foo[-1,]==x[-nrow(x),]))
436490 test(all(foo@dates==x@dates))
437 ##lagdistIts-function------------------------------------------------
491 }
492
493 ##lagdistIts-function------------------------------------------------
494 test.lagdist.its <- function() {
438495 foo <- lagdistIts(x[,1],1,3)
439496 test(all.equal(foo[,1],lagIts(x[,1],1)))
440497 test(all.equal(foo[,2],lagIts(x[,1],2)))
441498 test(all.equal(foo[,3],lagIts(x[,1],3)))
442499 test(all.equal(x@dates,foo@dates))
443 ##its-subset*********************************************************
444 ##rangeIts-function--------------------------------------------------
500 }
501
502 ##its-subset*********************************************************
503 ##rangeIts-function--------------------------------------------------
504 test.its.range <- function() {
505 its.format("%Y-%m-%d")
445506 now <- format.POSIXct(Sys.time(),format=its.format())
446507 tomorrow <- format.POSIXct(Sys.time()+24*60*60,format=its.format())
447 test(identical(appendIts(rangeIts(x,start=now),rangeIts(x,end=now)),x))
448 test(nrow(rangeIts(x,start=now,end=now))==0)
449 test(nrow(rangeIts(x,start=now,end=tomorrow))==1)
508 test(identical(appendIts(rangeIts(x,start=tomorrow),rangeIts(x,end=now)),x))
509 test(nrow(rangeIts(x,start=now,end=now))==1)
510 test(nrow(rangeIts(x,start=now,end=tomorrow))==2)
511 }
512
513 test.subset.its <- function() {
450514 ##[-method-----------------------------------------------------------
451515 i1 <- rep(c(TRUE,FALSE),5)
452516 j1 <- c(TRUE,FALSE,TRUE)
465529 mat2[c(TRUE,FALSE),c(TRUE,FALSE)] <- c(1000,2000)
466530 x2[c(TRUE,FALSE),c(TRUE,FALSE)] <- c(1000,2000)
467531 test(all(mat2==x2))
468 ##its-times**********************************************************
469 ##daysecondIts-function----------------------------------------------
470 ##weekdayIts-function------------------------------------------------
532 }
533
534 ##its-times**********************************************************
535 ##daysecondIts-function----------------------------------------------
536 ##weekdayIts-function------------------------------------------------
537 test.times.its <- function() {
471538 foo <- as.POSIXlt(mytimes)$wday
472539 test(identical((foo>0 & foo<6),weekdayIts(x)))
473 ##collapseIts--------------------------------------------------------
474 if(as.numeric(R.Version()$major)*100+as.numeric(R.Version()$minor)*10>=1080 & New)
475 {
476 foo <- newIts(ncol=4,per="w",find="l",extract=T)[1:5,]
477 foo[,1] <- c(NA,NA,NA,1,1)
478 foo[,2] <- 1
479 foo[,4] <- c(NA, 1, 1,1,1)
480 dimnames(foo)[[2]] <- c("A","A","B","A")
481 test(all.equal(collapseIts(foo),foo[,2:3]))
482 foo[5,1] <- 1.01
483 bar <- try(collapseIts(foo),silent=TRUE)
484 test(bar=="Error in collapseIts(foo) : column data must match in collapse function\n")
485 }
486
487 ##its-utilities******************************************************
488 ######################################################################################################################################################################################
489 ##fromirtsIts-function------------------------------------------------
490 ##identical(fromirtsIts(irts(x@dates,x)),x)
491
492 ##locf---------------------------------------------------------------
540 }
541
542 ##collapseIts--------------------------------------------------------
543 test.collapse.its <- function() {
544 foo <- newIts(ncol=4,period="week",find="last",extract=T)[1:5,]
545 foo[,1] <- c(NA,NA,NA,1,1)
546 foo[,2] <- 1
547 foo[,4] <- c(NA, 1, 1,1,1)
548 dimnames(foo)[[2]] <- c("A","A","B","A")
549 test(all.equal(collapseIts(foo),foo[,2:3]))
550 foo[5,1] <- 1.01
551 bar <- try(collapseIts(foo),silent=TRUE)
552 test(bar=="Error in collapseIts(foo) : column data must match in collapse function\n")
553 }
554
555 ##its-utilities******************************************************
556 ######################################################################################################################################################################################
557 ##fromirtsIts-function------------------------------------------------
558 ##identical(fromirtsIts(irts(x@dates,x)),x)
559
560 ##locf---------------------------------------------------------------
561 test.locf.its <- function() {
493562 foo <- x
494563 foo[2:4,] <- NA
495564 test(identical(dates(x),dates(foo)))
496
497 ##-Utility Methods-
498 ##validity check-----------------------------------------------------
499 ##dates<--method-----------------------------------------------------
500 ##[-method-----------------------------------------------------------
501
502 ##-Utility Functions-
503 ##addDimnames-function-----------------------------------------------
504 ##gap.its-function---------------------------------------------------
505 ##overlaps.its-function----------------------------------------------
506 ##overlapmatches.its-function----------------------------------------
507 ##namesmatch.its-function--------------------------------------------
508 ##its.format-function------------------------------------------------
509 ##simdates.its-function----------------------------------------------
510 ##***extractDates
565 }
566
567 ##-Utility Methods-
568 ##validity check-----------------------------------------------------
569 ##dates<--method-----------------------------------------------------
570 ##[-method-----------------------------------------------------------
571
572 ##-Utility Functions-
573 ##addDimnames-function-----------------------------------------------
574 ##gap.its-function---------------------------------------------------
575 ##overlaps.its-function----------------------------------------------
576 ##overlapmatches.its-function----------------------------------------
577 ##namesmatch.its-function--------------------------------------------
578 ##its.format-function------------------------------------------------
579 ##simdates.its-function----------------------------------------------
580 ##***extractDates
581 test.extract.its <- function() {
511582 its.format("%Y-%m-%d")
583 years <- 100:105
584 hoursecs <- 60*60
585 regdaysecs <- 24*hoursecs
586 monthdays <- c(28,29,30,31)
587 monthsecs <- c(monthdays*regdaysecs,monthdays*regdaysecs-hoursecs,monthdays*regdaysecs+hoursecs)
588 weeksecs <- 7*regdaysecs ##+hoursecs*c(-1,0,1)
589 daysecs <- regdaysecs+hoursecs*c(-1,0,1)
590 weekDaySelection <- 1:5
591
512592 TEST <- newIts(start="2003-11-17",end="2005-12-25")
513593 ##-select
514 test(all((as.numeric(extractIts(TEST,period="week",select=2)@dates)-as.numeric(extractIts(TEST,period="week",select=1)@dates))%in%daysecs))
594 test(all((as.numeric(extractIts(TEST,period="week",select=2)@dates)-as.numeric(extractIts(TEST,period="week",select=1)@dates))
595 %in% daysecs))
515596 ##-weekday
516597 test(all(as.POSIXlt(extractIts(TEST,weekday=TRUE)@dates)$wday
517598 %in%1:5))
523604 test(all(as.POSIXlt(extractIts(TEST,weekday=TRUE,select=weekDaySelection,period="week",find="first")@dates)$wday==1))
524605 ##-find
525606 test(all(as.POSIXlt(extractIts(TEST,weekday=TRUE,period="week",find="first")@dates[-1])$wday==1))
526 TESTX <-
527 extractIts(TEST[1:(length(TEST@dates)-2)],weekday=TRUE,period="week",find="last")@dates
607 TESTX <-extractIts(TEST[1:(length(TEST@dates)-2)],weekday=TRUE,period="week",find="last")@dates
528608 test(all(as.POSIXlt(TESTX)$wday[-length(TESTX)]==5))
529609 ##-period
530610 test(all(as.POSIXlt(extractIts(TEST,weekday=FALSE,period="year",find="first",partial=FALSE)@dates)$yday==0))
538618 test(all((as.numeric(extractIts(TEST,period="week",select=2)@dates)-as.numeric(extractIts(TEST,period="week",select=1)@dates))%in%daysecs))
539619 test(all(as.POSIXlt(extractIts(TEST,period="week",select=2)@dates)$wday==2))
540620 test(all(as.POSIXlt(extractIts(TEST,period="week",select=2,weekday=TRUE)@dates)$wday==2))
541 ##
542 cat(
543 paste(sep="",
544 "******************************\n* its test suite successful *\n",
545 "* ",
546 R.version.string,
547 "* ",
548 "\n",
549 "******************************\n")
550 )
551 }
621 }
622
623 testIts <- function() {
624 test.arith()
625 test.extractor()
626 test.names()
627 test.dates()
628 test.core()
629 test.cumsum()
630 test.diff()
631 test.is.its()
632 test.as.its()
633 test.its.creation()
634 test.new.its()
635 ##test.plot.its()
636 test.read.write.its()
637 test.its.summary()
638 test.its.start()
639 test.its.end()
640 test.aligned.its()
641 test.append.its()
642 test.union.its()
643 test.intersect.its()
644 test.lag.its()
645 test.lagdist.its()
646 test.its.range()
647 test.subset.its()
648 test.times.its()
649 test.collapse.its()
650 test.locf.its()
651 test.extract.its()
652 }
653
654 cat(paste("* its test suite successful *\n",R.version.string,"\n"))
655
552656 ##debug(testIts)
553 require(its)
554 ##require(Rblp)
555 print(system.time(testIts(New=TRUE,graph=FALSE)))
556 print(system.time(testIts(New=TRUE,graph=TRUE)))
657 print(system.time(testIts()))
+14
-14
man/itsDef.rd less more
4141 representing the time-stamps of the irregular time-series
4242 object. The elements of the numeric vector are construed as the
4343 number of seconds since the beginning of 1970, see \code{\link{POSIXct}}.}
44 \item{start, end}{POSIXct or character representation of the start or end time-stamp,
44 \item{start, end}{POSIXct or character representation of the start or end time-stamp,
4545 if character, then the format is as specified by the argument \code{format}}
4646 \item{ncol}{number of columns of synthetic sequence of dates}
4747 \item{by}{time increment for synthetic sequence of dates, see \code{\link{seq.POSIXt}}}
48 \item{extract}{logical flag: if TRUE, a subset of the synthetic sequence of dates is extracted,
48 \item{extract}{logical flag: if TRUE, a subset of the synthetic sequence of dates is extracted,
4949 see \code{\link{extractIts}}}
5050 \item{x}{a numeric matrix representing the values of the
5151 irregular time-series object. In the case of coercion in as.its, the first
5252 column is taken to be the time-stamps, in seconds since the beginning
5353 of 1970, see \code{\link{POSIXct}}.}
54 \item{object} { }
54 \item{object}{an R object convertible to its}
5555 \item{names}{a vector of mode character}
56 \item{format}{a formatting string, see \code{\link{format.POSIXct}}, defaults to
56 \item{format}{a formatting string, see \code{\link{format.POSIXct}}, defaults to
5757 \code{its.format()}}
5858 \item{formatDefault}{a formatting string, see \code{\link{format.POSIXct}},
5959 defaults to \code{"\%Y-\%m-\%d"} if \code{formatDefault} is not specified.}
7373 An object of class "its" inherits matrix arithmetic methods. The matrix
7474 has dimnames: dimnames[[1]] is populated with a text representation of
7575 "dates", using a format which is defined by the function its.format. These
76 dates are not used in computations - all computations use the
76 dates are not used in computations - all computations use the
7777 POSIX representation. The dates are required to be in ascending order.
78
78
7979 When matrix multiplication is applied to an "its", the result is of class
80 matrix. It is possible to restore the "its" class (see examples) - its()
80 matrix. It is possible to restore the "its" class (see examples) - its()
8181 is in this sense idempotent i.e. its(mat)==its(its(mat)). Note however that
8282 the dates will be taken from dimnames[[1]], so the accuracy of this
8383 operation depends on the format of the dates.
8484
85 \code{newIts} is a utility for creating a new "its" using a series of 'semi-regular'
85 \code{newIts} is a utility for creating a new "its" using a series of 'semi-regular'
8686 time-stamps, such as weekday, weekly, monthend etc. Conceptually the date sequence
8787 generation has two parts. The first part is the generation of a sequence using
88 \code{\link{seq.POSIXt}} - the arguments from, to, and by are passed to this function. The second
89 part (which is optional, and applies only if extract=TRUE) is an extraction,
88 \code{\link{seq.POSIXt}} - the arguments from, to, and by are passed to this function. The second
89 part (which is optional, and applies only if extract=TRUE) is an extraction,
9090 performed by \code{extractIts}. See \code{\link{extractIts}} for details of the arguments,
9191 which are passed via '...' .
9292
93 The function \code{its.format} assigns a private variable and returns its value. The
93 The function \code{its.format} assigns a private variable and returns its value. The
9494 value of this default format persists in the session until reset. The purpose of the
95 function is one of convenience: to access and/or assign the default text format for dates
95 function is one of convenience: to access and/or assign the default text format for dates
9696 in the "its" package, and hence reduce the need to define the format repeatedly in a session.
9797
9898 }
118118 \code{\link{itsTimes}},
119119 \code{\link{itsSubset}},
120120 \code{\link{itsFin}},
121 \code{\link{itsInterp}}
121 \code{\link{itsInterp}}
122122 }
123123
124124 \examples{
136136 its.format("\%a \%d \%b \%Y")
137137 newIts(start="2003-09-30",end="2005-05-05",format="\%Y-\%m-\%d",period="month",find="last",extract=TRUE,weekday=TRUE)
138138 newIts(start=ISOdate(2003,12,24,0),end=ISOdate(2004,1,10),extract=TRUE,weekday=TRUE)
139 its.format("\%Y\%m\%d")
139 its.format("\%Y\%m\%d")
140140 as(newIts(),"data.frame")
141141 }