racket-benchmarks: add tool for simple bar plots

pkgs/racket-benchmarks/info.rkt

@@ -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))

pkgs/racket-benchmarks/mini-bar-plot/bm.rkt

@@ -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))
+

pkgs/racket-benchmarks/mini-bar-plot/main.rkt

@@ -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))))))