Mercurial > repos > guerler > charts
comparison charts.r @ 35:f294f5c9608c draft
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.') |