Mercurial > repos > guerler > charts

comparison charts.r @ 35:f294f5c9608c draft

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Uploaded
author guerler
date Fri, 09 May 2014 00:58:55 -0400
parents b079b17dcb4a
children 5164a18d0916
comparison
equal deleted inserted replaced
34:f92f68399023 35:f294f5c9608c
1 #!/usr/bin/Rscript 1 #!/usr/bin/Rscript
2 2
3 #' Returns file name of calling Rscript 3 # load getopt library
4 #' 4 library('getopt');
5 #' \code{get_Rscript_filename} returns the file name of calling Rscript
6 #' @return A string with the filename of the calling script.
7 #' If not found (i.e. you are in a interactive session) returns NA.
8 #'
9 #' @export
10 get_Rscript_filename <- function() {
11 prog <- sub("--file=", "", grep("--file=", commandArgs(), value=TRUE)[1])
12 if( .Platform$OS.type == "windows") {
13 prog <- gsub("\\\\", "\\\\\\\\", prog)
14 }
15 prog
16 }
17
18 #' Recursively sorts a list
19 #'
20 #' \code{sort_list} returns a sorted list
21 #' @param unsorted_list A list.
22 #' @return A sorted list.
23 #' @export
24 sort_list <- function(unsorted_list) {
25 for(ii in seq(along=unsorted_list)) {
26 if(is.list(unsorted_list[[ii]])) {
27 unsorted_list[[ii]] <- sort_list(unsorted_list[[ii]])
28 }
29 }
30 unsorted_list[sort(names(unsorted_list))]
31 }
32
33 #' #!/path/to/Rscript
34 #' library('getopt');
35 #' #get options, using the spec as defined by the enclosed list.
36 #' #we read the options from the default: commandArgs(TRUE).
37 #' spec = matrix(c(
38 #' 'verbose', 'v', 2, "integer",
39 #' 'help' , 'h', 0, "logical",
40 #' 'count' , 'c', 1, "integer",
41 #' 'mean' , 'm', 1, "double",
42 #' 'sd' , 's', 1, "double"
43 #' ), byrow=TRUE, ncol=4);
44 #' opt = getopt(spec);
45 #'
46 #' # if help was asked for print a friendly message
47 #' # and exit with a non-zero error code
48 #' if ( !is.null(opt$help) ) {
49 #' cat(getopt(spec, usage=TRUE));
50 #' q(status=1);
51 #' }
52 #'
53 #' #set some reasonable defaults for the options that are needed,
54 #' #but were not specified.
55 #' if ( is.null(opt$mean ) ) { opt$mean = 0 }
56 #' if ( is.null(opt$sd ) ) { opt$sd = 1 }
57 #' if ( is.null(opt$count ) ) { opt$count = 10 }
58 #' if ( is.null(opt$verbose ) ) { opt$verbose = FALSE }
59 #'
60 #' #print some progress messages to stderr, if requested.
61 #' if ( opt$verbose ) { write("writing...",stderr()); }
62 #'
63 #' #do some operation based on user input.
64 #' cat(paste(rnorm(opt$count,mean=opt$mean,sd=opt$sd),collapse="\n"));
65 #' cat("\n");
66 #'
67 #' #signal success and exit.
68 #' #q(status=0);
69 getopt = function (spec=NULL,opt=commandArgs(TRUE),command=get_Rscript_filename(),usage=FALSE,debug=FALSE) {
70
71 # littler compatibility - map argv vector to opt
72 if (exists("argv", where = .GlobalEnv, inherits = FALSE)) {
73 opt = get("argv", envir = .GlobalEnv);
74 }
75
76 ncol=4;
77 maxcol=6;
78 col.long.name = 1;
79 col.short.name = 2;
80 col.has.argument = 3;
81 col.mode = 4;
82 col.description = 5;
83
84 flag.no.argument = 0;
85 flag.required.argument = 1;
86 flag.optional.argument = 2;
87
88 result = list();
89 result$ARGS = vector(mode="character");
90
91 #no spec. fail.
92 if ( is.null(spec) ) {
93 stop('argument "spec" must be non-null.');
94
95 #spec is not a matrix. attempt to coerce, if possible. issue a warning.
96 } else if ( !is.matrix(spec) ) {
97 if ( length(spec)/4 == as.integer(length(spec)/4) ) {
98 warning('argument "spec" was coerced to a 4-column (row-major) matrix. use a matrix to prevent the coercion');
99 spec = matrix( spec, ncol=ncol, byrow=TRUE );
100 } else {
101 stop('argument "spec" must be a matrix, or a character vector with length divisible by 4, rtfm.');
102 }
103
104 #spec is a matrix, but it has too few columns.
105 } else if ( dim(spec)[2] < ncol ) {
106 stop(paste('"spec" should have at least ",ncol," columns.',sep=''));
107
108 #spec is a matrix, but it has too many columns.
109 } else if ( dim(spec)[2] > maxcol ) {
110 stop(paste('"spec" should have no more than ",maxcol," columns.',sep=''));
111
112 #spec is a matrix, and it has some optional columns.
113 } else if ( dim(spec)[2] != ncol ) {
114 ncol = dim(spec)[2];
115 }
116
117 #sanity check. make sure long names are unique, and short names are unique.
118 if ( length(unique(spec[,col.long.name])) != length(spec[,col.long.name]) ) {
119 stop(paste('redundant long names for flags (column ',col.long.name,').',sep=''));
120 }
121 if ( length(na.omit(unique(spec[,col.short.name]))) != length(na.omit(spec[,col.short.name])) ) {
122 stop(paste('redundant short names for flags (column ',col.short.name,').',sep=''));
123 }
124 # convert numeric type to double type
125 spec[,4] <- gsub("numeric", "double", spec[,4])
126
127 # if usage=TRUE, don't process opt, but generate a usage string from the data in spec
128 if ( usage ) {
129 ret = '';
130 ret = paste(ret,"Usage: ",command,sep='');
131 for ( j in 1:(dim(spec))[1] ) {
132 ret = paste(ret,' [-[-',spec[j,col.long.name],'|',spec[j,col.short.name],']',sep='');
133 if (spec[j,col.has.argument] == flag.no.argument) {
134 ret = paste(ret,']',sep='');
135 } else if (spec[j,col.has.argument] == flag.required.argument) {
136 ret = paste(ret,' <',spec[j,col.mode],'>]',sep='');
137 } else if (spec[j,col.has.argument] == flag.optional.argument) {
138 ret = paste(ret,' [<',spec[j,col.mode],'>]]',sep='');
139 }
140 }
141 # include usage strings
142 if ( ncol >= 5 ) {
143 max.long = max(apply(cbind(spec[,col.long.name]),1,function(x)length(strsplit(x,'')[[1]])));
144 ret = paste(ret,"\n",sep='');
145 for (j in 1:(dim(spec))[1] ) {
146 ret = paste(ret,sprintf(paste(" -%s|--%-",max.long,"s %s\n",sep=''),
147 spec[j,col.short.name],spec[j,col.long.name],spec[j,col.description]
148 ),sep='');
149 }
150 }
151 else {
152 ret = paste(ret,"\n",sep='');
153 }
154 return(ret);
155 }
156
157 #XXX check spec validity here. e.g. column three should be convertible to integer
158
159 i = 1;
160
161 while ( i <= length(opt) ) {
162 if ( debug ) print(paste("processing",opt[i]));
163
164 current.flag = 0; #XXX use NA
165 optstring = opt[i];
166
167
168 #long flag
169 if ( substr(optstring, 1, 2) == '--' ) {
170 if ( debug ) print(paste(" long option:",opt[i]));
171
172 optstring = substring(optstring,3);
173
174 this.flag = NA;
175 this.argument = NA;
176 kv = strsplit(optstring, '=')[[1]];
177 if ( !is.na(kv[2]) ) {
178 this.flag = kv[1];
179 this.argument = paste(kv[-1], collapse="=");
180 } else {
181 this.flag = optstring;
182 }
183
184 rowmatch = grep( this.flag, spec[,col.long.name],fixed=TRUE );
185
186 #long flag is invalid, matches no options
187 if ( length(rowmatch) == 0 ) {
188 stop(paste('long flag "', this.flag, '" is invalid', sep=''));
189
190 #long flag is ambiguous, matches too many options
191 } else if ( length(rowmatch) > 1 ) {
192 # check if there is an exact match and use that
193 rowmatch = which(this.flag == spec[,col.long.name])
194 if(length(rowmatch) == 0) {
195 stop(paste('long flag "', this.flag, '" is ambiguous', sep=''));
196 }
197 }
198
199 #if we have an argument
200 if ( !is.na(this.argument) ) {
201 #if we can't accept the argument, bail out
202 if ( spec[rowmatch, col.has.argument] == flag.no.argument ) {
203 stop(paste('long flag "', this.flag, '" accepts no arguments', sep=''));
204
205 #otherwise assign the argument to the flag
206 } else {
207 storage.mode(this.argument) = spec[rowmatch, col.mode];
208 result[spec[rowmatch, col.long.name]] = this.argument;
209 i = i + 1;
210 next;
211 }
212
213 #otherwise, we don't have an argument
214 } else {
215 #if we require an argument, bail out
216 ###if ( spec[rowmatch, col.has.argument] == flag.required.argument ) {
217 ### stop(paste('long flag "', this.flag, '" requires an argument', sep=''));
218
219 #long flag has no attached argument. set flag as present. set current.flag so we can peek ahead later and consume the argument if it's there
220 ###} else {
221 result[spec[rowmatch, col.long.name]] = TRUE;
222 current.flag = rowmatch;
223 ###}
224 }
225
226 #short flag(s)
227 } else if ( substr(optstring, 1, 1) == '-' ) {
228 if ( debug ) print(paste(" short option:",opt[i]));
229
230 these.flags = strsplit(optstring,'')[[1]];
231
232 done = FALSE;
233 for ( j in 2:length(these.flags) ) {
234 this.flag = these.flags[j];
235 rowmatch = grep( this.flag, spec[,col.short.name],fixed=TRUE );
236
237 #short flag is invalid, matches no options
238 if ( length(rowmatch) == 0 ) {
239 stop(paste('short flag "', this.flag, '" is invalid', sep=''));
240
241 #short flag is ambiguous, matches too many options
242 } else if ( length(rowmatch) > 1 ) {
243 stop(paste('short flag "', this.flag, '" is ambiguous', sep=''));
244
245 #short flag has an argument, but is not the last in a compound flag string
246 } else if ( j < length(these.flags) & spec[rowmatch,col.has.argument] == flag.required.argument ) {
247 stop(paste('short flag "', this.flag, '" requires an argument, but has none', sep=''));
248
249 #short flag has no argument, flag it as present
250 } else if ( spec[rowmatch,col.has.argument] == flag.no.argument ) {
251 result[spec[rowmatch, col.long.name]] = TRUE;
252 done = TRUE;
253
254 #can't definitively process this flag yet, need to see if next option is an argument or not
255 } else {
256 result[spec[rowmatch, col.long.name]] = TRUE;
257 current.flag = rowmatch;
258 done = FALSE;
259 }
260 }
261 if ( done ) {
262 i = i + 1;
263 next;
264 }
265 }
266
267 #invalid opt
268 if ( current.flag == 0 ) {
269 stop(paste('"', optstring, '" is not a valid option, or does not support an argument', sep=''));
270 #TBD support for positional args
271 #if ( debug ) print(paste('"', optstring, '" not a valid option. It is appended to getopt(...)$ARGS', sep=''));
272 #result$ARGS = append(result$ARGS, optstring);
273
274 # some dangling flag, handle it
275 } else if ( current.flag > 0 ) {
276 if ( debug ) print(' dangling flag');
277 if ( length(opt) > i ) {
278 peek.optstring = opt[i + 1];
279 if ( debug ) print(paste(' peeking ahead at: "',peek.optstring,'"',sep=''));
280
281 #got an argument. attach it, increment the index, and move on to the next option. we don't allow arguments beginning with '-' UNLESS
282 #specfile indicates the value is an "integer" or "double", in which case we allow a leading dash (and verify trailing digits/decimals).
283 if ( substr(peek.optstring, 1, 1) != '-' |
284 #match negative double
285 ( substr(peek.optstring, 1, 1) == '-'
286 & regexpr('^-[0123456789]*\\.?[0123456789]+$',peek.optstring) > 0
287 & spec[current.flag, col.mode]== 'double'
288 ) |
289 #match negative integer
290 ( substr(peek.optstring, 1, 1) == '-'
291 & regexpr('^-[0123456789]+$',peek.optstring) > 0
292 & spec[current.flag, col.mode]== 'integer'
293 )
294 ) {
295 if ( debug ) print(paste(' consuming argument *',peek.optstring,'*',sep=''));
296
297 storage.mode(peek.optstring) = spec[current.flag, col.mode];
298 result[spec[current.flag, col.long.name]] = peek.optstring;
299 i = i + 1;
300
301 #a lone dash
302 } else if ( substr(peek.optstring, 1, 1) == '-' & length(strsplit(peek.optstring,'')[[1]]) == 1 ) {
303 if ( debug ) print(' consuming "lone dash" argument');
304 storage.mode(peek.optstring) = spec[current.flag, col.mode];
305 result[spec[current.flag, col.long.name]] = peek.optstring;
306 i = i + 1;
307
308 #no argument
309 } else {
310 if ( debug ) print(' no argument!');
311
312 #if we require an argument, bail out
313 if ( spec[current.flag, col.has.argument] == flag.required.argument ) {
314 stop(paste('flag "', this.flag, '" requires an argument', sep=''));
315
316 #otherwise set flag as present.
317 } else if (
318 spec[current.flag, col.has.argument] == flag.optional.argument |
319 spec[current.flag, col.has.argument] == flag.no.argument
320 ) {
321 x = TRUE;
322 storage.mode(x) = spec[current.flag, col.mode];
323 result[spec[current.flag, col.long.name]] = x;
324 } else {
325 stop(paste("This should never happen.",
326 "Is your spec argument correct? Maybe you forgot to set",
327 "ncol=4, byrow=TRUE in your matrix call?"));
328 }
329 }
330 #trailing flag without required argument
331 } else if ( spec[current.flag, col.has.argument] == flag.required.argument ) {
332 stop(paste('flag "', this.flag, '" requires an argument', sep=''));
333
334 #trailing flag without optional argument
335 } else if ( spec[current.flag, col.has.argument] == flag.optional.argument ) {
336 x = TRUE;
337 storage.mode(x) = spec[current.flag, col.mode];
338 result[spec[current.flag, col.long.name]] = x;
339
340 #trailing flag without argument
341 } else if ( spec[current.flag, col.has.argument] == flag.no.argument ) {
342 x = TRUE;
343 storage.mode(x) = spec[current.flag, col.mode];
344 result[spec[current.flag, col.long.name]] = x;
345 } else {
346 stop("this should never happen (2). please inform the author.");
347 }
348 #no dangling flag, nothing to do.
349 } else {
350 }
351
352 i = i+1;
353 }
354 return(result);
355 }
356 5
357 # convert multi parameter string (i.e. key1: value, key2: value, ...) to object 6 # convert multi parameter string (i.e. key1: value, key2: value, ...) to object
358 split <- function(argument){ 7 split <- function(argument){
359 # process parameter string 8 # process parameter string
360 options <- list() 9 options <- list()
419 header_date <- paste('# date -', Sys.time(), sep=' ') 68 header_date <- paste('# date -', Sys.time(), sep=' ')
420 header_module <- paste('# module -', opt$module, sep=' ') 69 header_module <- paste('# module -', opt$module, sep=' ')
421 header_settings <- paste('# settings -', opt$settings, sep=' ') 70 header_settings <- paste('# settings -', opt$settings, sep=' ')
422 header_columns <- paste('# columns -', opt$columns, sep=' ') 71 header_columns <- paste('# columns -', opt$columns, sep=' ')
423 72
424 # fill gaps 73 # check result
425 if (length(l) > 0) { 74 if (length(l) > 0) {
426 # print details 75 # print details
427 if (!is.null(opt$verbose)) { 76 if (!is.null(opt$verbose)) {
428 print ('Columns:') 77 print ('Columns:')
429 print (columns) 78 print (columns)
449 write.table(l, file=output, row.names=FALSE, col.names = FALSE, quote=FALSE, sep='\t') 98 write.table(l, file=output, row.names=FALSE, col.names = FALSE, quote=FALSE, sep='\t')
450 99
451 # close file 100 # close file
452 close(output) 101 close(output)
453 } else { 102 } else {
103 # print details
454 print ('Columns:') 104 print ('Columns:')
455 print (columns) 105 print (columns)
456 print ('Settings:') 106 print ('Settings:')
457 print (settings) 107 print (settings)
458 print ('No output generated.') 108 print ('No output generated.')