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