1split.lexis.1D <-
2function(lex, breaks, time.scale, tol)
3{
4    time.scale <- check.time.scale(lex, time.scale)
5
6    ## Entry and exit times on the time scale that we are splitting
7    time1 <- lex[,time.scale, drop=FALSE]
8    time2 <- time1 + lex$lex.dur
9
10    ## Augment break points with +/- infinity
11    breaks <- sort( unique( breaks ) )
12    I1 <- c(-Inf, breaks)
13    I2 <- c(breaks,Inf)
14
15    ## Arrays containing data on each interval (rows) for each subject (cols)
16    en <- apply(time1, 1, pmax, I1)     # Entry time
17    ex <- apply(time2, 1, pmin, I2)     # Exit time
18    NR <- nrow(en)
19    NC <- ncol(en)
20
21    ## Does subject contribute follow-up time to this interval?
22    ## (intervals shorter than tol are ignored)
23    valid <- en < ex - tol
24    dur <- ex - en; dur[!valid] <- 0    # Time spent in interval
25
26    ## Cumulative time since entry at the start of each interval
27    time.since.entry <- rbind(0, apply(dur,2,cumsum)[-NR,,drop=FALSE])
28
29    cal.new.entry <- function(entry.time) {
30        sweep(time.since.entry, 2, entry.time, "+")[valid]
31    }
32
33    old.entry <- lex[, timeScales(lex), drop=FALSE]
34    new.entry <- lapply(old.entry, cal.new.entry)
35
36    ## Status calculation
37    aug.valid <- rbind(valid, rep(FALSE, NC))
38    last.valid <- valid & !aug.valid[-1,]
39    any.valid <- apply(valid,2,any)
40
41    new.Xst <- matrix( lex$lex.Cst, NR, NC, byrow=TRUE)
42    new.Xst[last.valid] <- lex$lex.Xst[any.valid]
43
44    n.interval <- apply(valid, 2, sum)
45    new.lex <- Lexis("entry" = new.entry,
46                     "duration" = dur[valid],
47                     "id" = rep(lex$lex.id, n.interval),
48                     "entry.status" = rep(lex$lex.Cst, n.interval),
49                     "exit.status" = new.Xst[valid])
50
51    ## Update breaks attribute and tranfer time.since attribute
52    breaks.attr <- attr(lex, "breaks")
53    breaks.attr[[time.scale]] <- sort(c(breaks.attr[[time.scale]], breaks))
54    attr(new.lex, "breaks") <- breaks.attr
55    attr(new.lex, "time.since") <- attr(lex, "time.since")
56    return(new.lex)
57}
58
59
60splitLexis <- function(lex, breaks, time.scale=1, tol= .Machine$double.eps^0.5)
61{
62  ## Advise the uninformed user...
63  if( inherits(lex,"stacked.Lexis") )
64    stop( "It makes no sense to time-split after stacking ---\n",
65    "split your original Lexis object and stack that to get what you want.\n")
66
67
68  ## Set temporary, unique, id variable
69  lex$lex.tempid <- lex$lex.id
70  lex$lex.id <- 1:nrow(lex)
71
72  ## Save auxiliary data
73  aux.data.names <- setdiff(names(lex), timeScales(lex))
74  aux.data.names <- aux.data.names[substr(aux.data.names,1,4) != "lex."]
75  aux.data <- lex[, c("lex.id","lex.tempid", aux.data.names), drop=FALSE]
76
77  ## Check for NAs in the timescale
78  ts <- check.time.scale(lex, time.scale)
79  ts.miss <- any(is.na(lex[,ts]))
80  if( ts.miss )
81    {
82    na.lex <- lex[ is.na(lex[,ts]),]
83       lex <- lex[!is.na(lex[,ts]),]
84    cat( "Note: NAs in the time-scale \"", ts, "\", you split on\n")
85    }
86
87  ## If states are factors convert to numeric while splitting
88  factor.states <- is.factor( lex$lex.Cst )
89  if( factor.states )
90    {
91    state.levels <- levels( lex$lex.Cst )
92    nstates     <- nlevels( lex$lex.Cst )
93    lex$lex.Cst <- as.integer( lex$lex.Cst )
94    lex$lex.Xst <- as.integer( lex$lex.Xst )
95    }
96
97  ## Split the data
98  lex <- split.lexis.1D(lex, breaks, time.scale, tol)
99
100  ## Reinstitute the factor levels
101  if( factor.states )
102    {
103    lex$lex.Cst <- factor( lex$lex.Cst, levels=1:nstates, labels=state.levels )
104    lex$lex.Xst <- factor( lex$lex.Xst, levels=1:nstates, labels=state.levels )
105    }
106
107  ## Put the NA-rows back
108  if( ts.miss ) lex <- rbind( lex, na.lex[,colnames(lex)] )
109
110  ## Save attributes
111  lex.attr <- attributes(lex)
112  ## Merge
113  lex <- merge.data.frame(lex, aux.data, by="lex.id")
114  ## Restore attributes
115  attr(lex,"breaks") <- lex.attr$breaks
116  attr(lex,"time.scales") <- lex.attr$time.scales
117  attr(lex,"time.since") <- lex.attr$time.since
118  class(lex) <- c("Lexis", "data.frame")
119  ## Restore id variable
120  lex$lex.id <- lex$lex.tempid
121  lex$lex.tempid <- NULL
122
123  return(lex)
124}
125