suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket-benchmarks: add tool for simple bar plots

Browse Source
This commit is contained in:
Matthew Flatt 2019-05-10 09:55:48 -06:00
parent bb7836e734
commit 35e98675b6
3 changed files with 393 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-benchmarks/info.rkt
View File

@ -8,7 +8,10 @@
"scheme-lib"
"racket-test"
"typed-racket-lib"
"gui-lib"))
"plot"
"draw-lib"
"gui-lib"
"pict-lib"))
(define pkg-desc "Racket benchmarks")
(define pkg-authors '(eli jay mflatt robby samth stamourv))

214
pkgs/racket-benchmarks/mini-bar-plot/bm.rkt Normal file
View File

@ -0,0 +1,214 @@
#lang racket/base
(require racket/class
racket/cmdline
racket/path
racket/draw
pict
"main.rkt")
(module+ main
(define current-dest-file (make-parameter #f))
(define current-sort (make-parameter #f))
(define current-mean-wrt (make-parameter #f))
(define current-rev-inputs (make-parameter null))
(define current-rev-implementations (make-parameter null))
(define inputs
(command-line
#:once-each
[("-o" "--dest") file "Write plot to <file> inferring format from extension"
(current-dest-file file)]
[("--sort-wrt") impl vs-impl "Sort by ratio of <impl> to <vs-impl>"
(current-sort (cons (string->symbol impl) (string->symbol vs-impl)))]
[("--mean-wrt") impl "Show goemetric mean of ration relative to <impl>"
(current-mean-wrt (string->symbol impl))]
#:multi
[("++file") file impl "Load <file> using <impl> instead file's recorded <impl>"
(let ([impl (string->symbol impl)])
(current-rev-inputs (cons (input file (lambda (n) impl))
(current-rev-inputs))))]
[("++bar") impl name color "Set order and colors of bars"
(current-rev-implementations (cons (implementation (string->symbol impl) name color)
(current-rev-implementations)))]
#:args file
(append
(reverse (current-rev-inputs))
(for/list ([file (in-list file)])
(input file (lambda (n) n))))))
(define p (benchmark-plot inputs
#:implementations (reverse (current-rev-implementations))
#:sort-by-ratio (current-sort)
#:geometic-mean-wrt (current-mean-wrt)))
(let ([file (current-dest-file)])
(cond
[(not file)
(parameterize ([current-command-line-arguments (vector)])
((dynamic-require 'slideshow 'slide) (scale p 0.5)))]
[else
(define ext (path-get-extension file))
(define bm-format
(case ext
[(#".png") 'png]
[(#".jpg" #".jpeg") 'jpeg]
[(#".bmp") 'bmp]
[else #f]))
(cond
[bm-format
(send (pict->bitmap p) save-file file bm-format)
(void)]
[(equal? ext #".pdf")
(define pss (new ps-setup%))
(send pss set-scaling 1.0 1.0)
(parameterize ([current-ps-setup pss])
(define dc (new pdf-dc%
[interactive #f]
[as-eps #t]
[width (pict-width p)]
[height (pict-height p)]
[output file]))
(send dc start-doc "plot")
(send dc start-page)
(draw-pict p dc 0 0)
(send dc end-page)
(send dc end-doc))]
[else
(raise-user-error 'bm "could not determine format for output: ~a" file)])])))
(struct input (file impl->impl))
(struct implementation (key name color))
(define (benchmark-plot inputs
#:implementations [implementations null]
#:sort-by-ratio [sort-by-ratio/names #f]
#:geometic-mean-wrt [geo-mean-impl #f])
(define all-timess
(for/fold ([accum #hasheq()]) ([i (in-list inputs)])
(get-times #:accum accum
(input-file i)
#:impl->impl (input-impl->impl i))))
(define med-timess (median-times all-timess))
(define given-keys
(for/list ([i (in-list implementations)])
(implementation-key i)))
(define keys (append given-keys
(for/list ([k (in-hash-keys med-timess)]
#:unless (member k given-keys))
k)))
(define names
(for/list ([k (in-list keys)])
(or (for/or ([i (in-list implementations)])
(and (eq? k (implementation-key i))
(implementation-name i)))
k)))
(define timess
(for/list ([k (in-list keys)])
(hash-ref med-timess k)))
(define colors
(let ([cs (for/list ([i (in-list implementations)])
(implementation-color i))])
(append cs
(generate-colors (list-tail keys (length cs))
#:used cs))))
(define (find-key k)
(or (for/or ([a-k (in-list keys)]
[i (in-naturals)])
(and (eq? k a-k) i))
(raise-user-error 'bm "sort key not found: ~a" k)))
(define sort-by-ratio
(and sort-by-ratio/names
(cons (find-key (car sort-by-ratio/names))
(find-key (cdr sort-by-ratio/names)))))
(define ((ratio-geo-mean wrt-times) times)
(define sq-ratios
(for/list ([(k v) (in-hash times)])
(expt (/ v (hash-ref wrt-times k)) 2)))
(hash '|geometric mean|
(sqrt (/ (apply + sq-ratios) (length sq-ratios)))))
(define (plot timess
#:key->pict [key->pict (lambda (k) #f)])
(define base (mini-bar-plot names
timess
#:sort-ratio sort-by-ratio
#:columns 6
#:colors colors
#:key->pict key->pict
#:suffix " msec"))
(cond
[geo-mean-impl
(ht-append (* 2 (current-h-plot-sep))
(mini-bar-plot names
(map (ratio-geo-mean (hash-ref med-timess geo-mean-impl))
timess)
#:decimal-places 2
#:colors colors
#:key->pict (lambda (s) ((current-t) (format "~a" s))))
base)]
[else base]))
(define ((filter-times ?) ht)
(for/hasheq ([(k v) (in-hash ht)]
#:when (? k))
(values k v)))
(cond
[(ormap r5rs? (hash-keys (car timess)))
(vc-append (current-v-plot-sep)
(plot (map (filter-times (lambda (x) (not (r5rs? x)))) timess))
(plot (map (filter-times r5rs?) timess)
#:key->pict (lambda (k)
(colorize ((current-tt) (symbol->string k)) r5rs-color))))]
[else (plot timess)]))
(define (get-times f
#:accum [hts #hasheq()]
#:impl->impl [impl->impl (lambda (impl) impl)])
(call-with-input-file*
f
(lambda (i)
(for/fold ([hts hts]) ([i (in-port read i)])
(define impl (impl->impl (car i)))
(define ht (hash-ref hts impl #hasheq()))
(define k (rename (cadr i)))
(define t (caaddr i))
(define e (hash-ref ht k null))
(hash-set hts impl (if t
(hash-set ht k (cons t e))
ht))))))
(define (median-times hts)
(define (median l)
(list-ref (sort l <) (quotient (length l) 2)))
(for/hasheq ([(impl ht) (in-hash hts)])
(values impl
(for/hasheq ([(k e) (in-hash ht)]
#:unless (or (eq? k 'nothing)
(eq? k 'hello)))
(values k (median e))))))
(define (rename k)
(hash-ref #hasheq((mandelbrot-generic . mandelbrot-g)
(reversecomplement . reversecomp)
(spectralnorm-generic . spectralnorm-g)
(nbody-vec-generic . nbody-vec-g)
(cheapconcurrency . cheapconcur))
k
k))
(define r5rs-color "forestgreen")
(define r5rs-keys
'(conform destruct dynamic lattice maze peval psyntax scheme-c scheme-i scheme sort1))
(define (r5rs? key) (memq key r5rs-keys))

175
pkgs/racket-benchmarks/mini-bar-plot/main.rkt Normal file
View File

@ -0,0 +1,175 @@
#lang racket/base
(require pict
racket/draw
racket/list
racket/format)
(provide mini-bar-plot
current-h-plot-sep
current-v-plot-sep
current-tt
current-t
generate-colors)
(define current-h-plot-sep (make-parameter 24))
(define (current-v-plot-sep) (* 2 (current-h-plot-sep)))
(define (default-t s) (text s 'swiss 32))
(define (default-tt s) (text s '(bold . modern) 32))
(define current-t (make-parameter default-t))
(define current-tt (make-parameter default-tt))
(define (mini-bar-plot names
timess
#:colors [colors (generate-colors names)]
#:t [t (current-t)]
#:tt [tt (current-tt)]
#:measurement-t [measurement-t tt]
#:bar-t [bar-t t]
#:h-plot-sep [h-plot-sep (current-h-plot-sep)]
#:v-plot-sep [v-plot-sep (* 2 h-plot-sep)]
#:columns [columns 1]
#:bar-sep [bar-sep 0]
#:bar-text-scale [bar-text-scale 0.5]
#:vertical-bars? [vertical-bars? #f]
#:width [W 200]
#:height [H (* 2 bar-text-scale (if vertical-bars? 70 30))]
#:normalize-max? [normalize-max? #f]
#:pin-max? [pin-max? #f]
#:max [starting-max 0]
#:sort-ratio [sort-ratio #f]
#:key->pict [key->pict (lambda (k) #f)]
#:reverse? [reverse? #f]
#:ghost-label [ghost-label #f]
#:details [details (map (lambda (v) #hasheq()) timess)]
#:detail-spec [detail-spec #f]
#:display-scale [display-scale 1]
#:decimal-places [decimal-places 0]
#:fill-vertical? [fill-vertical? #f]
#:widen? [widen? vertical-bars?]
#:pad-left [pad-left 0]
#:prefix [prefix ""]
#:suffix [suffix ""])
(define keys ((if reverse? reverse values)
(sort (hash-keys (car timess))
(lambda (a b)
(cond
[sort-ratio
(define (ratio a)
(/ (hash-ref (list-ref timess (car sort-ratio)) a)
(hash-ref (list-ref timess (cdr sort-ratio)) a)))
(< (ratio a) (ratio b))]
[else (symbol<? a b)])))))
(define base-max (if normalize-max?
(for*/fold ([mx starting-max]) ([times (in-list timess)]
[t (in-hash-values times)])
(max mx t))
starting-max))
(define (overlay-detail bar total detail key)
(cond
[(not detail-spec) bar]
[else
(let loop ([bar bar] [delta 0] [spec detail-spec])
(cond
[(null? spec) bar]
[else
(define t (hash-ref (hash-ref detail key) (caar spec) 0))
(define dbar (colorize (filled-rectangle (* (pict-width bar) (/ t total))
H)
(cdar spec)))
(loop (rb-superimpose bar
(inset dbar 0 0 delta 0))
(+ delta (pict-width dbar))
(cdr spec))]))]))
(define (widen p) (if widen?
(let ([a (* 2/3 (pict-width p))])
(inset p (+ a pad-left) 0 a 0))
(if pad-left
(inset p pad-left 0 0 0)
p)))
(define plots (for/list ([key (in-list keys)])
(define max-time (if pin-max?
base-max
(for/fold ([mx base-max]) ([times (in-list timess)])
(max mx (hash-ref times key)))))
(vl-append
2
(or (key->pict key)
(measurement-t (~a key)))
(widen
(apply
(if vertical-bars? hb-append vr-append)
bar-sep
(for/list ([name (in-list names)]
[color (in-list colors)]
[times (in-list timess)]
[detail (in-list details)])
(define time (hash-ref times key))
((if vertical-bars? (lambda (sep a b) (vc-append sep b a)) hc-append)
5
(let ([l (colorize (if (pict? name) name (t (~a name))) color)])
(let ([p (if ghost-label
(if vertical-bars?
(ctl-superimpose l (ghost ghost-label))
(rtl-superimpose l (ghost ghost-label)))
l)])
(if vertical-bars?
(let ([p2 (scale p (min 1 (/ H (pict-width p))))])
(cc-superimpose p2 (blank 0 (pict-height p))))
p)))
(let ([lbl (scale (let ([tp (t (format "~a~a~a"
prefix
(~r (* time display-scale) #:precision decimal-places)
suffix))])
tp)
0.5)]
[bar (let ([bar (overlay-detail
(colorize (if vertical-bars?
(filled-rectangle H (* W (/ time (max 1 max-time))))
(filled-rectangle (* W (/ time (max 1 max-time))) H))
color)
time detail key)])
(if (and pin-max? (time . > . max-time))
(if vertical-bars?
(inset bar 0 (- W (pict-height bar)) 0 0)
(inset bar 0 0 (- W (pict-width bar)) 0))
bar))])
(define labelled-bar
((if vertical-bars? cb-superimpose lb-superimpose)
bar
(inset (colorize lbl "white")
4)))
((if vertical-bars? cb-superimpose lt-superimpose)
(pin-under (clip (refocus labelled-bar bar))
lbl lt-find
(colorize lbl color))
(if vertical-bars?
(blank H (if fill-vertical? W 0))
(blank W H)))))))))))
(define (pad plots)
(append plots
(let ([n (remainder (length plots) columns)])
(if (zero? n)
null
(make-list (- columns n) (blank))))))
(table columns
(pad plots)
cc-superimpose cc-superimpose
h-plot-sep v-plot-sep))
(define (generate-colors names #:used [used '()])
(define nice-colors (for/list ([c '("red" "blue" "forestgreen" "purple" "orange")]
#:unless (member c used))
c))
(define n (length names))
(define nice-n (length nice-colors))
(if (n . <= . nice-n)
(take nice-colors n)
(append nice-colors
(for ([i (in-range nice-n n)])
(make-color (modulo (* i 101) 256)
(modulo (* i 203) 256)
(modulo (* i 53) 256))))))