1Lexis.lines <-
2function( entry.date = NA,
3           exit.date = NA,
4          birth.date = NA,
5           entry.age = NA,
6            exit.age = NA,
7           risk.time = NA,
8            col.life = "black",
9            lwd.life = 2,
10                fail = NA,
11            cex.fail = 1,
12            pch.fail = c(NA,16),
13            col.fail = col.life,
14                data = NULL
15          )
16{
17    ## Get variables from data argument, if supplied, or from parent
18    ## frame if not.
19    entry.date <- eval(substitute(entry.date), data)
20    entry.age  <- eval(substitute(entry.age ), data)
21    exit.date  <- eval(substitute(exit.date ), data)
22    exit.age   <- eval(substitute(exit.age  ), data)
23    risk.time  <- eval(substitute(birth.date), data)
24    birth.date <- eval(substitute(birth.date), data)
25    fail       <- eval(substitute(fail      ), data)
26
27# If fail is numeric make it logical
28if( is.numeric( fail ) ) fail <- ( fail > 0 )
29
30# Complete the information on lifelines
31XX <- Life.lines( entry.date = entry.date,
32                   entry.age = entry.age,
33                   exit.date = exit.date,
34                    exit.age = exit.age,
35                   risk.time = risk.time,
36                  birth.date = birth.date )
37
38# Expand lwd.life/col.life/pch.fail/col.fail/cex.fail
39#
40Np <- nrow( XX )
41
42if( length( col.life )==1 ) col.life <- rep( col.life, Np  ) else
43if( length( col.life )!=length(fail) ) stop("col.life must have length 1 or length(fail)" )
44
45if( length( lwd.life )==1 ) lwd.life <- rep( lwd.life, Np ) else
46if( length( lwd.life )!=length(fail) ) stop("lwd.life must have length 1 or length(fail)" )
47
48if( length( col.fail )==1 ) col.fail <- rep( col.fail, Np ) else {
49if( length( col.fail )==2 ) col.fail <- col.fail[fail+1] }
50if( length( col.fail )!=length(fail) ) stop("col.fail must have length 1,2 or length(fail)" )
51
52if( length( pch.fail )==1 ) pch.fail <- rep( pch.fail, Np ) else
53if( length( pch.fail )==2 ) pch.fail <- pch.fail[fail+1]
54if( length( pch.fail )!=length(fail) ) stop("pch.fail must have length 1,2 or length(fail)" )
55
56if( length( cex.fail )==1 ) cex.fail <- rep( cex.fail, Np ) else
57if( length( cex.fail )==2 ) cex.fail <- cex.fail[fail+1]
58if( length( cex.fail )!=length(fail) ) stop("cex.fail must have length 1,2 or length(fail)" )
59
60# Was XX returned as a Date-object?
61# If so make a numerical version i LL, otherwise just a copy.
62#
63if( attr( XX, "Date" ) )
64  {
65  LL <- data.frame( lapply( XX, unclass ) )
66  LL[,c(1,3,5)] <- LL[,c(1,3,5)] / 365.25 + 1970
67  LL[,c(2,4,6)] <- LL[,c(2,4,6)] / 365.25
68  } else LL <- XX
69
70# Find age and date ranges in the current plot.
71#
72date <- par( "usr" )[1:2]
73age  <- par( "usr" )[3:4]
74
75# Plot the lifelines
76  segments( LL[,1], LL[,2], LL[,3], LL[,4],
77            lwd=lwd.life, col=col.life )
78# If there are any non-NAs for pch.fail then blank out the space
79# where they go before plotting the symbols
80  if( any( !is.na(pch.fail) ) )
81  points( LL[!is.na(pch.fail),3], LL[!is.na(pch.fail),4],
82          pch=16,
83          col="white", #par()$bg,
84          cex=cex.fail[!is.na(pch.fail)] )
85  points( LL[,3], LL[,4],
86          pch=pch.fail,
87          col=col.fail,
88          cex=cex.fail )
89
90# Return the untouched version of the completed dataframe
91#
92invisible( data.frame( XX, fail=fail ) )
93}
94