1do <- function(condition, expressions, device=NULL, file, append=FALSE,
2               multiplot=FALSE, ...)
3{
4  if(!condition)
5    return(invisible())
6
7  ## The following function is courtesy of Bill Dunlap, StatSci
8  strip.comments <- function(expr)
9  {
10    if (mode(expr) == "comment.expression") {
11      not.comment <- sapply(expr, function(ei)mode(ei)!="comment")
12      if (sum(not.comment)!=1)
13        stop("unexpected result: no non-comment in expression")
14      else {
15        Recall(expr[not.comment][[1]])
16      }
17    } else expr
18  }
19
20  condition <- as.character(substitute(condition))
21  scondition <-
22    if(under.unix)
23      condition
24    else
25      substring(sedit(condition, '.', ''), 1,8)
26
27  pcondition <-
28    if(multiplot)
29      substring(scondition,1,7)
30    else
31      scondition
32
33  do.file <-
34    if(missing(file)) {
35      if(length(ds <- .Options$do.file)==0)
36        ''
37      else
38        ds
39    } else file
40
41  do.prefix <- .Options$do.prefix
42
43  if(do.file!='') {
44    if(do.file=='condition')
45      sink(sink.file <- paste(if(length(do.prefix))
46                              paste(do.prefix,if(under.unix)'.' else '/',sep=''),
47                              paste(scondition, 'lst',sep='.'),
48                              sep=''), append=append)
49    else
50      sink(sink.file <- paste(do.file, '.lst',sep=''), append=append)
51  }
52
53  if(missing(device))
54    device <- .Options$do.device
55
56  if(length(device)) {
57    suffix <-
58      if(device %in% c('postscript','ps','ps.slide'))
59        'ps'
60      else if(device %in% c('win.slide','win.printer'))
61        'wmf'
62      else
63        'gr'
64
65    file <- paste(if(length(do.prefix))
66                    paste(do.prefix,
67                          if(under.unix)
68                            '.'
69                          else
70                            '/',
71                          sep=''),
72                  if(device!='ps.slide' && device!='win.slide')
73                    paste(pcondition, suffix, sep='.')
74                  else
75                    pcondition,
76                  sep='')
77
78    if(multiplot) {
79      if(under.unix)
80        stop('multiplot=T not meaningful under UNIX')
81
82      if(!(device %in% c('win.slide','win.printer')))
83        stop('multiplot only meaningful for device=win.slide,win.printer')
84
85      file <- paste(file,'#',sep='')
86    }
87
88    get(device)(file, ...)
89  }
90
91  do.echo <- .Options$do.echo
92  if(length(do.echo)==0)
93    do.echo <- TRUE
94
95  do.comments <- .Options$do.comments
96  if(length(do.comments)==0)
97    do.comments <- FALSE
98
99  invis.fctns <- c('plot','lines','points','abline','text','mtext','title',
100                   'impute', 'survplot')
101
102  ## generic functions whose body ends in UseMethod but are invisible
103  ## this list should grow
104  for(ex in substitute(expressions)) {
105    lv <- eval(ex)
106    exs <- strip.comments(ex)
107    m <- mode(exs)
108    if(m == 'name' ||
109       (m=='call' &&
110        (length(exs$pl)==0 ||
111         (is.logical(exs$pl) && !exs$pl)))) {
112      ## some functions called to plot (pl=T) - don't auto print results
113      inv <-
114        if(m != 'call')
115          FALSE
116        else  {
117          ## see if expression is call to function
118          ## with body ending in invisible()
119	  ex1 <- as.character(exs[1])
120	  inv <-
121            if(any(ex1==invis.fctns))
122              TRUE
123            else if(exists(ex1, mode='function')) {
124              f <- get(ex1, mode='function')
125              f <- f[[length(f)]]
126              f1 <- as.character(f)[1]
127              if(f1=='invisible' || f1=='.Cur.pic')
128                TRUE
129              else {
130                m <- mode(f)
131                if(m=='{') {
132                  f <- f[[length(f)]];
133                  f1 <- as.character(f)[1]
134                }
135
136                f1=='invisible' || f1=='.Cur.pic'
137              }
138            } else FALSE
139	}
140
141      if(!inv) {
142        if(do.echo) {
143          cat('\n');
144          dput(if(do.comments)
145                 ex
146               else
147                 exs);
148          cat('\n')
149        }
150
151        print(lv)
152      }
153    }
154  }
155
156  if(length(device))
157    dev.off()
158
159  if(do.file!='') {
160    sink()
161    cat('Print output ',
162        if(append)
163          'appended'
164        else
165          'written',
166        ' to file "', sink.file, '".\n', sep='')
167
168    all.files <- unique(c(.Options$.all.do.files, sink.file))
169    options(.all.do.files=all.files, TEMPORARY=FALSE)
170    if(under.unix) {
171      pwd.home <- unix('pwd;echo $HOME')
172      cat('$1', paste(paste(pwd.home[1],all.files,sep='/'), collapse=' '),' &\n',
173          file=paste(pwd.home[2],'/.lst',sep=''))
174      unix('chmod +x $HOME/.lst')
175    }
176  }
177
178  invisible()
179}
180