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