forked from metrumresearchgroup/metrumrg
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathtemporal.R
145 lines (138 loc) · 5.41 KB
/
temporal.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
as.numeric.chartime <- function(x,format,...)as.numeric(unclass(as.POSIXct(strptime(x,format),tz='GMT')))
as.chartime <- function(x,...)UseMethod('as.chartime')
as.chartime.numeric <- function(x,format,mark=TRUE,...){
y <- strftime(as.POSIXct(as.numeric(x),tz='GMT',origin='1970-01-01'),format=format,tz='GMT')
y[is.infinite(x)] <- x[is.infinite(x)]
z <- rep('',length(y))
if(mark){
s <- !is.na(x) & is.finite(x) & x%%60!=0
z[s] <- '+'
}
y <- glue(y,z)
y[is.na(x)] <- NA
y
}
as.mTime <- function(x,...)UseMethod('as.mTime')
as.mTime.numeric <- function(x,...){
x <- round(x)
x[is.finite(x)] <- x[is.finite(x)]%%(60*60*24)
structure(x, class = c('mTime','timepoint','timeline','numeric'))
}
as.mTime.character <- function(x,format='%H:%M',...)as.mTime(as.numeric.chartime(x,format))
as.mDate <- function(x,...)UseMethod('as.mDate')
as.mDate.numeric <- function(x,...){
x <- as.numeric(x)
x <- round(x)
f <- is.finite(x)
x[f] <- x[f] - x[f]%%(60*60*24)
structure(x, class = c('mDate','timepoint','timeline','numeric'))
}
as.mDate.character <- function(x,format='%Y-%m-%d',...)as.mDate(as.numeric.chartime(x,format))
as.mDate.sasdate <-function(x,...)as.mDate(as.Date(x, origin="1960-01-01",...))
as.mDateTime <- function(x,...)UseMethod('as.mDateTime')
as.mDateTime.numeric <- function(x,...){
x <- round(x)
structure(x, class = c('mDateTime','timepoint','timeline','numeric'))
}
as.mDateTime.character <- function(x,format='%Y-%m-%d %H:%M',...)as.mDateTime(as.numeric.chartime(x,format))
as.mDateTime.mDate <- function(x,y=0,...)as.mDateTime(as.numeric(x)+as.numeric(as.second(y)))
format.mTime <- function(x,format='%H:%M',mark=TRUE,...)as.chartime(x,format,mark)
format.mDate <- function(x,format='%Y-%m-%d',mark=TRUE,...)as.chartime(x,format,mark)
format.mDateTime <- function(x,format='%Y-%m-%d %H:%M',mark=TRUE,...)as.chartime(x,format,mark)
as.character.timepoint <- function(x,...)format(x,...)
print.timepoint <-function(x,...){
print(format(x,...),quote=FALSE)
invisible(x)
}
c.timeline <- function (..., recursive = FALSE){
args <- list(...)
oldclass <- class(args[[1]])
structure(c(unlist(lapply(args, unclass))), class = oldclass)
}
seq.timeline <- function (from, to, by, length.out, along.with, ...){
if(missing(from))stop('seq.timeline requires "from"')
#defaults for interval can be set, if neither specified nor implied
specified <- !missing(by)
implied <- !missing(to) & (!missing(length.out) | !missing(along.with))
if (!specified & !implied){
if (inherits(from, "mTime")) by = 60 * 60
if (inherits(from, "mDate")) by = 60 * 60 * 24
if (inherits(from, "mDateTime")) by = 60 * 60 * 24
}
if(!missing(to)){
stopifnot(identical(class(from),class(to)))
to <- as.numeric(to)
}
theClass <- class(from)
from <- as.numeric(from)
#if(missing(length.out))length.out=NULL
#if(missing(along.with))along.with=NULL
args <- list(from=from)
if(!missing(to))args <- c(args,list(to=to))
if(!missing(by))args <- c(args,list(by=by))
if(!missing(length.out))args <- c(args,list(length.out=length.out))
if(!missing(along.with))args <- c(args,list(along.with=along.with))
args=c(args,list(...))
x <- do.call(seq,args)
class(x) <- theClass
x
}
as.mTime.mTime <- function(x,...)x
as.mDate.mDate <- function(x,...)x
as.mDateTime.mDateTime <- function(x,...)x
rep.timeline <- function (x, ...) structure(rep(as.numeric(x),...),class=class(x))
`[.timeline` <- function (x, ..., drop = TRUE)structure(NextMethod(.Generic), class = oldClass(x))
`[[.timeline` <- function (x, ..., drop = TRUE)structure(NextMethod(.Generic), class = oldClass(x))
`[<-.timepoint` <- function (x, ..., value){
if (!(length(value)))return(x)
if(all(is.na(value)))value <- as.numeric(value)
if(inherits(x,'mTime'))value <- as.mTime(value)
if(inherits(x,'mDate'))value <- as.mDate(value)
if(inherits(x,'mDateTime'))value <- as.mDateTime(value)
cl <- oldClass(x)
class(x) <- class(value) <- NULL
x <- NextMethod(.Generic)
class(x) <- cl
x
}
xtfrm.timepoint <- function(x,...)as.numeric(x)
as.mDate.Date <- function(x,...)as.mDate(round(as.numeric(x))*86400)
as.mDateTime.POSIXct <- function(x,...)as.mDateTime(round(as.numeric(x)))
as.mDateTime.POSIXlt <- function(x,...)as.mDateTime(as.POSIXct(x))
as.mTime.times <- function(x,...)as.mTime(as.numeric(x)*86400)
as.mDate.dates <- function(x,...)as.mDate(as.numeric(x)*86400)
as.mDateTime.chron <- function(x,...)as.mDateTime(as.numeric(x)*86400)
unique.timepoint <- function(x, incomparables=FALSE,...)unique.numeric_version(x,incomparables,...)
Summary.timepoint <- function (..., na.rm=FALSE)
{
ok <- switch(.Generic, max = , min = , range = TRUE, FALSE)
if (!ok)
stop(.Generic, " not defined for timepoint objects")
val <- NextMethod(.Generic)
class(val) <- oldClass(list(...)[[1L]])
val
}
toSAS.mDateTime <- function(x, format="", format.info=NULL){
diff <- as.mDate('1970-01-01') - as.mDate('1960-01-01')
x <- as.second(x)
x <- x + diff
attr(x, "SASformat") <- format
x
}
toSAS.mDate <- function(x, format="", format.info=NULL){
diff <- as.day(as.mDate('1970-01-01') - as.mDate('1960-01-01'))
x <- as.day(as.second(x))
x <- x + diff
attr(x, "SASformat") <- format
x
}
toSAS.mTime <- function(x, format="", format.info=NULL){
x <- as.numeric(x)
attr(x, "SASformat") <- format
x
}
#as.vector.timepoint <- function (x, mode = "any"){
# if (mode == "any") x
# else as.vector(unclass(x), mode)
#}
#aperm.timepoint <- aperm.table