Mercurial > repos > guerler > charts

comparison charts.r @ 4:b079b17dcb4a draft

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Uploaded
author guerler
date Thu, 17 Apr 2014 11:19:54 -0400
parents
children f294f5c9608c
comparison
equal deleted inserted replaced
3:65f4abe945aa 4:b079b17dcb4a
1 #!/usr/bin/Rscript
2
3 #' Returns file name of calling Rscript
4 #'
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
357 # convert multi parameter string (i.e. key1: value, key2: value, ...) to object
358 split <- function(argument){
359 # process parameter string
360 options <- list()
361 list <- gsub("\\s","", argument)
362 list <- strsplit(list, ",")
363 if (length(list) > 0) {
364 list <- list[[1]]
365 for (entry in list) {
366 pair <- strsplit(entry, ":")
367 if (length(pair) > 0) {
368 pair <- pair[[1]]
369 if (length(pair) == 2) {
370 options[[pair[1]]] <- pair[2]
371 }
372 }
373 }
374 }
375 return(options)
376 }
377
378 # get options, using the spec as defined by the enclosed list.
379 spec = matrix(c(
380 'workdir', 'w', 1, 'character', 'Work directory',
381 'module', 'm', 1, 'character', 'Module name',
382 'input', 'i', 1, 'character', 'Input tabular file',
383 'columns', 'c', 1, 'character', 'Columns string',
384 'settings', 's', 1, 'character', 'Settings string',
385 'output', 'o', 1, 'character', 'Output tabular file',
386 'help', 'h', 0, '', 'Help',
387 'verbose', 'v', 0, '', 'Verbose'
388 ), byrow=TRUE, ncol=5);
389 opt = getopt(spec);
390
391 # show help
392 if ( !is.null(opt$help) ||
393 is.null(opt$module) ||
394 is.null(opt$input) ||
395 is.null(opt$columns) ||
396 is.null(opt$output)) {
397 cat(getopt(spec, usage=TRUE))
398 q(status=1);
399 }
400
401 # read columns/settings
402 columns = split(opt$columns)
403 settings = split(opt$settings)
404
405 # read table
406 table <- read.table(opt$input)
407
408 # identify module file
409 module_file = paste(opt$workdir, opt$module, '.r', sep='')
410
411 # source module
412 source(module_file)
413
414 # run module
415 l = wrapper (table, columns, settings)
416
417 # header
418 header_title <- '# title - Chart Utilities (charts)'
419 header_date <- paste('# date -', Sys.time(), sep=' ')
420 header_module <- paste('# module -', opt$module, sep=' ')
421 header_settings <- paste('# settings -', opt$settings, sep=' ')
422 header_columns <- paste('# columns -', opt$columns, sep=' ')
423
424 # fill gaps
425 if (length(l) > 0) {
426 # print details
427 if (!is.null(opt$verbose)) {
428 print ('Columns:')
429 print (columns)
430 print ('Settings:')
431 print (settings)
432 print ('Result:')
433 print (l)
434 }
435
436 # create output file
437 output <- file(opt$output, open='wt')
438
439 # write header
440 writeLines('#', output)
441 writeLines(header_title, output)
442 writeLines(header_date, output)
443 writeLines(header_module, output)
444 writeLines(header_settings, output)
445 writeLines(header_columns, output)
446 writeLines('#', output)
447
448 # write table
449 write.table(l, file=output, row.names=FALSE, col.names = FALSE, quote=FALSE, sep='\t')
450
451 # close file
452 close(output)
453 } else {
454 print ('Columns:')
455 print (columns)
456 print ('Settings:')
457 print (settings)
458 print ('No output generated.')
459 }